formal paramater madness

formal paramater madness

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable
open import lemmas-matching
open import disjointness

module expandability where
  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = _ , _ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | _ , _ , τ' , D  = _ , _ , ESAsc D
    expandability-synth (SVar x) = _ , _ , ESVar x
    expandability-synth (SAp dis wt1 m wt2)
      with expandability-ana (ASubsume wt1 (match-consist m)) | expandability-ana wt2
    ... | _ , _ , _ , D1 | _ , _ , _ , D2 = _ , _ , ESAp dis (expand-ana-disjoint dis D1 D2) wt1 m D1 D2
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole new wt)
      with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole (expand-new-disjoint-synth new wt') wt'
    expandability-synth (SLam x₁ wt)
      with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana {e = e} (ASubsume D x₁)
      with expandability-synth D
    -- these cases just pass through, but we need to pattern match so we can prove things aren't holes
    expandability-ana {e = c} (ASubsume D x₁)                    | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = e ·: x} (ASubsume D x₁)               | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = X x} (ASubsume D x₁)                  | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = ·λ x e} (ASubsume D x₁)               | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = ·λ x [ x₁ ] e} (ASubsume D x₂)        | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₂
    expandability-ana {e = e1 ∘ e2} (ASubsume D x₁)              | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    -- the two holes are special-cased
    expandability-ana {e = ⦇⦈[ x ]} (ASubsume _ _ )                   | _ , _ , _  = _ , _ , _ , EAEHole
    expandability-ana {Γ} {⦇ e ⦈[ x ]} (ASubsume (SNEHole new wt) x₂) | _ , _ , ESNEHole x₁ D' with expandability-synth wt
    ... | w , y , z =  _ , _ , _ , EANEHole (expand-new-disjoint-synth new z) z
    -- the lambda cases
    expandability-ana (ALam x₁ m wt)
      with expandability-ana wt
    ... | _ , _ , _ , D' = _ , _ , _ , EALam x₁ m D'

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable
open import lemmas-matching
open import disjointness

module expandability where
  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = _ , _ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | _ , _ , τ' , D  = _ , _ , ESAsc D
    expandability-synth (SVar {n = n} x) = _ , _ , ESVar x
    expandability-synth (SAp dis wt1 m wt2)
      with expandability-ana (ASubsume wt1 (match-consist m)) | expandability-ana wt2
    ... | _ , _ , _ , D1 | _ , _ , _ , D2 = _ , _ , ESAp dis (expand-ana-disjoint dis D1 D2) wt1 m D1 D2
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole new wt)
      with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole (expand-new-disjoint-synth new wt') wt'
    expandability-synth (SLam x₁ wt)
      with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana {e = e} (ASubsume D x₁)
      with expandability-synth D
    -- these cases just pass through, but we need to pattern match so we can prove things aren't holes
    expandability-ana {e = c} (ASubsume D x₁)                    | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = e ·: x} (ASubsume D x₁)               | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = X x} (ASubsume D x₁)                  | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = ·λ x e} (ASubsume D x₁)               | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = ·λ x [ x₁ ] e} (ASubsume D x₂)        | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₂
    expandability-ana {e = e1 ∘ e2} (ASubsume D x₁)              | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    -- the two holes are special-cased
    expandability-ana {e = ⦇⦈[ x ]} (ASubsume _ _ )                   | _ , _ , _  = _ , _ , _ , EAEHole
    expandability-ana {Γ} {⦇ e ⦈[ x ]} (ASubsume (SNEHole new wt) x₂) | _ , _ , ESNEHole x₁ D' with expandability-synth wt
    ... | w , y , z =  _ , _ , _ , EANEHole (expand-new-disjoint-synth new z) z
    -- the lambda cases
    expandability-ana (ALam x₁ m wt)
      with expandability-ana wt
    ... | _ , _ , _ , D' = _ , _ , _ , EALam x₁ m D'


now uses equational reasoning

now uses equational reasoning

module Nat where

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

_+_ : ℕ → ℕ → ℕ
zero   + b = b
succ a + b = succ (a + b)

_×_ : ℕ → ℕ → ℕ
zero   × b = zero
succ a × b = (a × b) + b

open import Relation.Binary.PropositionalEquality

0-is-right-identity-of-+ : ∀ (n : ℕ) → n + zero ≡ n
0-is-right-identity-of-+ zero     = refl
0-is-right-identity-of-+ (succ n) = cong succ (0-is-right-identity-of-+ n)

+-is-associative : ∀ (a b c : ℕ) → a + (b + c) ≡ (a + b) + c
+-is-associative zero     b c = refl
+-is-associative (succ a) b c = cong succ (+-is-associative a b c)

lemma : ∀ (a b : ℕ) → a + succ b ≡ succ (a + b)
lemma zero     b = refl
lemma (succ a) b = cong succ (lemma a b)

import Relation.Binary.EqReasoning as EqR
open module EqNat = EqR (setoid ℕ)

+-is-commutative : ∀ (a b : ℕ) → a + b ≡ b + a
+-is-commutative a zero     = 0-is-right-identity-of-+ a
+-is-commutative a (succ b) =
  begin
    a + succ b
      ≈⟨ lemma a b ⟩
    succ (a + b)
      ≈⟨ cong succ (+-is-commutative a b) ⟩
    succ (b + a)
      ≈⟨ refl ⟩
    succ b + a
  ∎

module Nat where

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

_+_ : ℕ → ℕ → ℕ
zero   + b = b
succ a + b = succ (a + b)

_×_ : ℕ → ℕ → ℕ
zero   × b = zero
succ a × b = (a × b) + b

open import Relation.Binary.PropositionalEquality

0-is-right-identity-of-+ : ∀ (n : ℕ) → n + zero ≡ n
0-is-right-identity-of-+ zero     = refl
0-is-right-identity-of-+ (succ n) = cong succ (0-is-right-identity-of-+ n)

+-is-associative : ∀ (a b c : ℕ) → a + (b + c) ≡ (a + b) + c
+-is-associative zero     b c = refl
+-is-associative (succ a) b c = cong succ (+-is-associative a b c)

lemma : ∀ (a b : ℕ) → a + succ b ≡ succ (a + b)
lemma zero     b = refl
lemma (succ a) b = cong succ (lemma a b)

+-is-commutative : ∀ (a b : ℕ) → a + b ≡ b + a
+-is-commutative a zero     = 0-is-right-identity-of-+ a
+-is-commutative a (succ b)
  = trans (lemma a b) (cong succ (+-is-commutative a b))


Renamed one function.

Renamed one function.

Ignore-this: 9c78acc0d4b0f6406274ce4cd5708f45

darcs-hash:20110402162531-3bd4e-972702749229997e6b55c5c45134d470e56c6257.gz

------------------------------------------------------------------------------
-- Testing
------------------------------------------------------------------------------

module Draft.FOTC.Data.Bool.AndTotality where

open import FOTC.Base

open import FOTC.Data.Bool.Type

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

postulate
  thm : ∀ {b}(P : D → Set) → (Bool b ∧ P true ∧ P false) → P b
-- The ATPs couldn't prove this postulate.
-- {-# ATP prove thm #-}

postulate
  thm₁ : ∀ {P : D → Set}{x y z} → Bool x → P y → P z → P (if x then y else z)
-- The ATPs couldn't prove this postulate.
-- {-# ATP prove thm₁ #-}

-- Typing of the if-then-else.
if-T : ∀ (P : D → Set){x y z} → Bool x → P y → P z →
       P (if x then y else z)
if-T P {y = y} tB Py Pz = subst P (sym (if-true y)) Py
if-T P {z = z} fB Py Pz = subst P (sym (if-false z)) Pz

_&&_ : D → D → D
x && y = if x then y else false
{-# ATP definition _&&_ #-}

postulate
  &&-Bool : ∀ {x y} → Bool x → Bool y → Bool (x && y)
{-# ATP prove &&-Bool if-T #-}

&&-Bool₁ : ∀ {x y} → Bool x → Bool y → Bool (x && y)
&&-Bool₁ {y = y} tB By = prf
  where
    postulate prf : Bool (true && y)
    {-# ATP prove prf if-T #-}
&&-Bool₁ {y = y} fB By = prf
  where
    postulate prf : Bool (false && y)
    {-# ATP prove prf if-T #-}

&&-Bool₂ : ∀ {x y} → Bool x → Bool y → Bool (x && y)
&&-Bool₂ tB By = if-T Bool tB By fB
&&-Bool₂ fB By = if-T Bool fB By fB

------------------------------------------------------------------------------
-- Testing
------------------------------------------------------------------------------

module Draft.FOTC.Data.Bool.AndTotality where

open import FOTC.Base

open import FOTC.Data.Bool.Type

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

postulate
  thm : ∀ {b}(P : D → Set) → (Bool b ∧ P true ∧ P false) → P b
-- The ATPs couldn't prove this postulate.
-- {-# ATP prove thm #-}

postulate
  thm₁ : ∀ {P : D → Set}{x y z} → Bool x → P y → P z → P (if x then y else z)
-- The ATPs couldn't prove this postulate.
-- {-# ATP prove thm₁ #-}

Bool-elim : ∀ (P : D → Set){x y z} → Bool x → P y → P z →
            P (if x then y else z)
Bool-elim P {y = y} tB Py Pz = subst P (sym (if-true y)) Py
Bool-elim P {z = z} fB Py Pz = subst P (sym (if-false z)) Pz

_&&_ : D → D → D
x && y = if x then y else false
{-# ATP definition _&&_ #-}

postulate
  &&-Bool : ∀ {x y} → Bool x → Bool y → Bool (x && y)
{-# ATP prove &&-Bool Bool-elim #-}

&&-Bool₁ : ∀ {x y} → Bool x → Bool y → Bool (x && y)
&&-Bool₁ {y = y} tB By = prf
  where
    postulate prf : Bool (true && y)
    {-# ATP prove prf Bool-elim #-}
&&-Bool₁ {y = y} fB By = prf
  where
    postulate prf : Bool (false && y)
    {-# ATP prove prf Bool-elim #-}

&&-Bool₂ : ∀ {x y} → Bool x → Bool y → Bool (x && y)
&&-Bool₂ tB By = Bool-elim Bool tB By fB
&&-Bool₂ fB By = Bool-elim Bool fB By fB


Minor changes.

Minor changes.

------------------------------------------------------------------------------
-- Main properties of the McCarthy 91 function
------------------------------------------------------------------------------

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

-- The main properties proved of the McCarthy 91 function (called
-- mc91) are

-- 1. The function always terminates.
-- 2. For all n, n < mc91 n + 11.
-- 3. For all n > 100, then mc91 n = n - 10.
-- 4. For all n <= 100, then mc91 n = 91.

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOTC.Program.McCarthy91.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP
open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.AuxiliaryPropertiesATP
open import FOTC.Program.McCarthy91.McCarthy91
open import FOTC.Program.McCarthy91.WF-Relation
open import FOTC.Program.McCarthy91.WF-Relation.LT2WF-RelationATP
open import FOTC.Program.McCarthy91.WF-Relation.Induction.Acc.WF-ATP

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

mc91-res : ∀ {n} → N n → (n > [100] ∧ mc91 n ≡ n ∸ [10]) ∨
                         (n ≯ [100] ∧ mc91 n ≡ [91])
mc91-res = ≪-wfind A h
  where
  A : D → Set
  A d = (d > [100] ∧ mc91 d ≡ d ∸ [10]) ∨
        (d ≯ [100] ∧ mc91 d ≡ [91])

  h : ∀ {m} → N m → (∀ {k} → N k → k ≪ m → A k) → A m
  h {m} Nm f with x>y∨x≯y Nm 100-N
  ... | inj₁ m>100 = inj₁ ( m>100 , mc91-eq-aux m m>100 )
  ... | inj₂ m≯100 with x≯Sy→x≯y∨x≡Sy Nm 99-N m≯100
  ... | inj₂ m≡100 = inj₂ ( m≯100 , mc91-res-aux mc91-res-100 m≡100 )
  ... | inj₁ m≯99 with x≯Sy→x≯y∨x≡Sy Nm 98-N m≯99
  ... | inj₂ m≡99 = inj₂ ( m≯100 , mc91-res-aux mc91-res-99 m≡99 )
  ... | inj₁ m≯98 with x≯Sy→x≯y∨x≡Sy Nm 97-N m≯98
  ... | inj₂ m≡98 = inj₂ ( m≯100 , mc91-res-aux mc91-res-98 m≡98 )
  ... | inj₁ m≯97 with x≯Sy→x≯y∨x≡Sy Nm 96-N m≯97
  ... | inj₂ m≡97 = inj₂ ( m≯100 , mc91-res-aux mc91-res-97 m≡97 )
  ... | inj₁ m≯96 with x≯Sy→x≯y∨x≡Sy Nm 95-N m≯96
  ... | inj₂ m≡96 = inj₂ ( m≯100 , mc91-res-aux mc91-res-96 m≡96 )
  ... | inj₁ m≯95 with x≯Sy→x≯y∨x≡Sy Nm 94-N m≯95
  ... | inj₂ m≡95 = inj₂ ( m≯100 , mc91-res-aux mc91-res-95 m≡95 )
  ... | inj₁ m≯94 with x≯Sy→x≯y∨x≡Sy Nm 93-N m≯94
  ... | inj₂ m≡94 = inj₂ ( m≯100 , mc91-res-aux mc91-res-94 m≡94 )
  ... | inj₁ m≯93 with x≯Sy→x≯y∨x≡Sy Nm 92-N m≯93
  ... | inj₂ m≡93 = inj₂ ( m≯100 , mc91-res-aux mc91-res-93 m≡93 )
  ... | inj₁ m≯92 with x≯Sy→x≯y∨x≡Sy Nm 91-N m≯92
  ... | inj₂ m≡92 = inj₂ ( m≯100 , mc91-res-aux mc91-res-92 m≡92 )
  ... | inj₁ m≯91 with x≯Sy→x≯y∨x≡Sy Nm 90-N m≯91
  ... | inj₂ m≡91 = inj₂ ( m≯100 , mc91-res-aux mc91-res-91 m≡91 )
  ... | inj₁ m≯90 with x≯Sy→x≯y∨x≡Sy Nm 89-N m≯90
  ... | inj₂ m≡90 = inj₂ ( m≯100 , mc91-res-aux mc91-res-90 m≡90 )
  ... | inj₁ m≯89 = inj₂ ( m≯100 , mc91-res-m≯89 )
    where
    m≤89 : m ≤ [89]
    m≤89 = x≯y→x≤y Nm 89-N m≯89

    mc91-res-m+11 : mc91 (m + [11]) ≡ [91]
    mc91-res-m+11 with f (x+11-N Nm) (<→≪ (x+11-N Nm) Nm m≯100 (x<x+11 Nm))
    ... | inj₁ ( m+11>100 , _ ) = ⊥-elim (x≤89→x+11>100→⊥ Nm m≤89 m+11>100)
    ... | inj₂ ( _ , res ) = res

    mc91-res-m≯89 : mc91 m ≡ [91]
    mc91-res-m≯89 = mc91x-res≯100 m [91] m≯100 mc91-res-m+11 mc91-res-91

------------------------------------------------------------------------------
-- Main properties

-- For all n > 100, then mc91 n = n - 10.
mc91-res>100 : ∀ {n} → N n → n > [100] → mc91 n ≡ n ∸ [10]
mc91-res>100 Nn n>100 with mc91-res Nn
... | inj₁ ( _     , res ) = res
... | inj₂ ( n≯100 , _ )   = ⊥-elim (x>y→x≤y→⊥ Nn 100-N n>100
                                               (x≯y→x≤y Nn 100-N n≯100))
-- For all n <= 100, then mc91 n = 91.
mc91-res≯100 : ∀ {n} → N n → n ≯ [100] → mc91 n ≡ [91]
mc91-res≯100 Nn n≯100 with mc91-res Nn
... | inj₁ ( n>100 , _   ) = ⊥-elim (x>y→x≤y→⊥ Nn 100-N n>100
                                               (x≯y→x≤y Nn 100-N n≯100))
... | inj₂ ( _     , res ) = res

-- The function always terminates.
mc91-N : ∀ {n} → N n → N (mc91 n)
mc91-N Nn with x>y∨x≯y Nn 100-N
... | inj₁ n>100 = subst N (sym (mc91-res>100 Nn n>100)) (∸-N Nn 10-N)
... | inj₂ n≮100 = subst N (sym (mc91-res≯100 Nn n≮100)) 91-N

-- For all n, n < mc91 n + 11.
mc91-N-ineq : ∀ {n} → N n → n < mc91 n + [11]
mc91-N-ineq = ≪-wfind A h
  where
  A : D → Set
  A d = d < mc91 d + [11]

  h : ∀ {m} → N m → (∀ {k} → N k → k ≪ m → A k) → A m
  h {m} Nm f with x>y∨x≯y Nm 100-N
  ... | inj₁ m>100 = x<mc91x+11>100 Nm m>100
  ... | inj₂ m≯100 =
    let mc91-m+11-N : N (mc91 (m + [11]))
        mc91-m+11-N = mc91-N (+-N Nm 11-N)

        h₁ : A (m + [11])
        h₁ = f (x+11-N Nm) (<→≪ (x+11-N Nm) Nm m≯100 (x<x+11 Nm))

        m<mc91m+11 : m < mc91 (m + [11])
        m<mc91m+11 = x+k<y+k→x<y Nm mc91-m+11-N 11-N h₁

        h₂ : A (mc91 (m + [11]))
        h₂ = f mc91-m+11-N (<→≪ mc91-m+11-N Nm m≯100 m<mc91m+11)

    in ( <-trans Nm mc91-m+11-N (x+11-N (mc91-N Nm))
                 m<mc91m+11
                 (mc91x+11<mc91x+11 m m≯100 h₂))

------------------------------------------------------------------------------
-- Main properties of the McCarthy 91 function
------------------------------------------------------------------------------

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

-- The main properties proved of the McCarthy 91 function (called
-- mc91) are

-- 1. The function always terminates.
-- 2. For all n, n < mc91 n + 11.
-- 3. For all n > 100, then mc91 n = n - 10.
-- 4. For all n <= 100, then mc91 n = 91.

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOTC.Program.McCarthy91.PropertiesATP where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP
open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.AuxiliaryPropertiesATP
open import FOTC.Program.McCarthy91.McCarthy91
open import FOTC.Program.McCarthy91.WF-Relation
open import FOTC.Program.McCarthy91.WF-Relation.LT2WF-RelationATP
open import FOTC.Program.McCarthy91.WF-Relation.Induction.Acc.WF-ATP

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

mc91-res : ∀ {n} → N n → (n > [100] ∧ mc91 n ≡ n ∸ [10]) ∨
                         (n ≯ [100] ∧ mc91 n ≡ [91])
mc91-res = ≪-wfind A h
  where
  A : D → Set
  A d = (d > [100] ∧ mc91 d ≡ d ∸ [10]) ∨
        (d ≯ [100] ∧ mc91 d ≡ [91])

  h : ∀ {m} → N m → (∀ {k} → N k → k ≪ m → A k) → A m
  h {m} Nm f with x>y∨x≯y Nm 100-N
  ... | inj₁ m>100 = inj₁ ( m>100 , mc91-eq-aux m m>100 )
  ... | inj₂ m≯100 with x≯Sy→x≯y∨x≡Sy Nm 99-N m≯100
  ... | inj₂ m≡100 = inj₂ ( m≯100 , mc91-res-aux mc91-res-100 m≡100 )
  ... | inj₁ m≯99 with x≯Sy→x≯y∨x≡Sy Nm 98-N m≯99
  ... | inj₂ m≡99 = inj₂ ( m≯100 , mc91-res-aux mc91-res-99 m≡99 )
  ... | inj₁ m≯98 with x≯Sy→x≯y∨x≡Sy Nm 97-N m≯98
  ... | inj₂ m≡98 = inj₂ ( m≯100 , mc91-res-aux mc91-res-98 m≡98 )
  ... | inj₁ m≯97 with x≯Sy→x≯y∨x≡Sy Nm 96-N m≯97
  ... | inj₂ m≡97 = inj₂ ( m≯100 , mc91-res-aux mc91-res-97 m≡97 )
  ... | inj₁ m≯96 with x≯Sy→x≯y∨x≡Sy Nm 95-N m≯96
  ... | inj₂ m≡96 = inj₂ ( m≯100 , mc91-res-aux mc91-res-96 m≡96 )
  ... | inj₁ m≯95 with x≯Sy→x≯y∨x≡Sy Nm 94-N m≯95
  ... | inj₂ m≡95 = inj₂ ( m≯100 , mc91-res-aux mc91-res-95 m≡95 )
  ... | inj₁ m≯94 with x≯Sy→x≯y∨x≡Sy Nm 93-N m≯94
  ... | inj₂ m≡94 = inj₂ ( m≯100 , mc91-res-aux mc91-res-94 m≡94 )
  ... | inj₁ m≯93 with x≯Sy→x≯y∨x≡Sy Nm 92-N m≯93
  ... | inj₂ m≡93 = inj₂ ( m≯100 , mc91-res-aux mc91-res-93 m≡93 )
  ... | inj₁ m≯92 with x≯Sy→x≯y∨x≡Sy Nm 91-N m≯92
  ... | inj₂ m≡92 = inj₂ ( m≯100 , mc91-res-aux mc91-res-92 m≡92 )
  ... | inj₁ m≯91 with x≯Sy→x≯y∨x≡Sy Nm 90-N m≯91
  ... | inj₂ m≡91 = inj₂ ( m≯100 , mc91-res-aux mc91-res-91 m≡91 )
  ... | inj₁ m≯90 with x≯Sy→x≯y∨x≡Sy Nm 89-N m≯90
  ... | inj₂ m≡90 = inj₂ ( m≯100 , mc91-res-aux mc91-res-90 m≡90 )
  ... | inj₁ m≯89 = inj₂ ( m≯100 , mc91-res-m≯89 )
    where
    m≤89 : m ≤ [89]
    m≤89 = x≯y→x≤y Nm 89-N m≯89

    mc91-res-m+11 : mc91 (m + [11]) ≡ [91]
    mc91-res-m+11 with f (x+11-N Nm) (<→≪ (x+11-N Nm) Nm m≯100 (x<x+11 Nm))
    ... | inj₁ ( m+11>100 , _ ) = ⊥-elim (x≤89→x+11>100→⊥ Nm m≤89 m+11>100)
    ... | inj₂ ( _ , res ) = res

    mc91-res-m≯89 : mc91 m ≡ [91]
    mc91-res-m≯89 = mc91x-res≯100 m [91] m≯100 mc91-res-m+11 mc91-res-91

------------------------------------------------------------------------------
-- Main properties

-- For all n > 100, then mc91 n = n - 10.
mc91-res>100 : ∀ {n} → N n → n > [100] → mc91 n ≡ n ∸ [10]
mc91-res>100 Nn n>100 with mc91-res Nn
... | inj₁ ( _     , res ) = res
... | inj₂ ( n≯100 , _ )   = ⊥-elim (x>y→x≤y→⊥ Nn 100-N n>100
                                               (x≯y→x≤y Nn 100-N n≯100))
-- For all n <= 100, then mc91 n = 91.
mc91-res≯100 : ∀ {n} → N n → n ≯ [100] → mc91 n ≡ [91]
mc91-res≯100 Nn n≯100 with mc91-res Nn
... | inj₁ ( n>100 , _   ) = ⊥-elim (x>y→x≤y→⊥ Nn 100-N n>100
                                               (x≯y→x≤y Nn 100-N n≯100))
... | inj₂ ( _     , res ) = res

-- The function always terminates.
mc91-N : ∀ {n} → N n → N (mc91 n)
mc91-N Nn with x>y∨x≯y Nn 100-N
... | inj₁ n>100 = subst N (sym (mc91-res>100 Nn n>100)) (∸-N Nn 10-N)
... | inj₂ n≮100 = subst N (sym (mc91-res≯100 Nn n≮100)) 91-N

-- For all n, n < mc91 n + 11.
mc91-N-ineq : ∀ {n} → N n → n < mc91 n + [11]
mc91-N-ineq = ≪-wfind A h
  where
  A : D → Set
  A d = d < mc91 d + [11]

  h : ∀ {m} → N m → (∀ {k} → N k → k ≪ m → A k) → A m
  h {m} Nm f with x>y∨x≯y Nm 100-N
  ... | inj₁ m>100 = x<mc91x+11>100 Nm m>100
  ... | inj₂ m≯100 =
    let mc91-m-11-N : N (mc91 (m + [11]))
        mc91-m-11-N = mc91-N (+-N Nm 11-N)

        h₁ : A (m + [11])
        h₁ = f (x+11-N Nm) (<→≪ (x+11-N Nm) Nm m≯100 (x<x+11 Nm))

        m<mc91m+11 : m < mc91 (m + [11])
        m<mc91m+11 = x+k<y+k→x<y Nm mc91-m-11-N 11-N h₁

        h₂ : A (mc91 (m + [11]))
        h₂ = f mc91-m-11-N (<→≪ mc91-m-11-N Nm m≯100 m<mc91m+11)

    in ( <-trans Nm mc91-m-11-N (x+11-N (mc91-N Nm))
                 m<mc91m+11
                 (mc91x+11<mc91x+11 m m≯100 h₂))


Lamport: more lemmas

Lamport: more lemmas

{-# OPTIONS --without-K #-}
open import Function using (_∘_)
open import Data.Nat.NP hiding (_==_)
open import Data.Product.NP renaming (map to ×-map)
open import Data.Bit hiding (_==_)
open import Data.Bits
open import Data.Bits.Properties
open import Data.Vec.NP
open import Relation.Binary.PropositionalEquality.NP
import Crypto.Sig.LamportOneBit

module Crypto.Sig.Lamport
          (#digest  : ℕ)
          (#seed    : ℕ)
          (#secret  : ℕ)
          (#message : ℕ)
          (hash-secret    : Bits #secret → Bits #digest)
          (seed-expansion : Bits #seed   → Bits (#message * 2* #secret))
          where

module OTS1 = Crypto.Sig.LamportOneBit #secret #digest hash-secret

H  = hash-secret
H² = map2* #secret #digest H

#signkey1   = OTS1.#signkey
#verifkey1  = OTS1.#verifkey
#signature1 = OTS1.#signature
#signkey    = #message * #signkey1
#verifkey   = #message * #verifkey1
#signature  = #message * #signature1

Digest     = Bits #digest
Seed       = Bits #seed
Secret     = Bits #secret
SignKey    = Bits #signkey
Message    = Bits #message
Signature  = Bits #signature
VerifKey   = Bits #verifkey

verif-key : SignKey → VerifKey
verif-key = map* #message OTS1.verif-key

module verifkey (vk : VerifKey) where
  vk1s = group #message #verifkey1 vk

  concat-vk1s : concat vk1s ≡ vk
  concat-vk1s = concat-group #message #verifkey1 vk

module signkey (sk : SignKey) where
  sk1s = group #message #signkey1 sk
  sc1s = map OTS1.signkey.skP sk1s
  vk   = verif-key sk
  open verifkey vk public
  sc1s-sk1s : map (uncurry _++_) sc1s ≡ sk1s
  sc1s-sk1s = ! map-∘ (uncurry _++_) OTS1.signkey.skP sk1s
            ∙ map-id= (take-drop-lem #secret) sk1s
  H-sc1s-sk1s : map (uncurry _++_ ∘ ×-map H H) sc1s ≡ map H² sk1s
  H-sc1s-sk1s = ! map-∘= (map2*-++ H) sc1s ∙ ap (map H²) sc1s-sk1s

module signature (sig : Signature) where
  sig1s = group #message #signature1 sig

  concat-sig1s : concat sig1s ≡ sig
  concat-sig1s = concat-group #message #secret sig

key-gen : Seed → VerifKey × SignKey
key-gen s = vk , sk
  module key-gen where
    sk = seed-expansion s
    vk = verif-key sk

sign : SignKey → Message → Signature
sign sk m = sig
  module sign where
    open signkey sk public
    sig1s = map OTS1.sign sk1s ⊛ m
    sig   = concat sig1s

    group-sig : group #message #signature1 sig ≡ sig1s
    group-sig = group-concat sig1s

verify : VerifKey → Message → Signature → Bit
verify vk m sig = and checks
  module verify where
    open verifkey  vk  public
    open signature sig public
    checks = map OTS1.verify vk1s ⊛ m ⊛ sig1s

private
  module lemma {#m} (sk : Bits (suc #m * #signkey1))
                    (b : Bit) (m : Bits #m) where
    skL  = take #signkey1 sk
    skH  = drop #signkey1 sk
    vkL  = OTS1.verif-key skL
    vkH  = map* #m OTS1.verif-key skH
    sigL = OTS1.sign skL b
    sigH = concat (map OTS1.sign (group #m #signkey1 skH) ⊛ m)

verifkey-is-hash-sig : ∀ sk m (open signkey sk)
                       → map (take2* _) m ⊛ vk1s
                       ≡ map H (map OTS1.sign sk1s ⊛ m)
verifkey-is-hash-sig sk m = lemma sk m
  module verifkey-is-hash-sig where
    lemma : ∀ {#m} sk m → map (take2* _) m ⊛ group #m #verifkey1 (map* #m OTS1.verif-key sk)
                        ≡ map hash-secret (map OTS1.sign (group #m #signkey1 sk) ⊛ m)
    lemma sk [] = refl
    lemma {suc #m} sk (b ∷ m)
      rewrite (let open lemma sk b m in take-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in drop-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in take-++ #signkey1 skL skH)
            | (let open lemma sk b m in drop-++ #signkey1 skL skH)
            | (let open lemma sk b m in lemma skH m)
            | (let open lemma sk b m in OTS1.verifkey-is-hash-sig skL b)
      = refl

verify-correct-sig : ∀ sk m → verify (verif-key sk) m (sign sk m) ≡ 1b
verify-correct-sig sk m = lemma sk m
  module verify-correct-sig where
    lemma : ∀ {#m} sk m → and (map OTS1.verify (group #m #verifkey1 (map* #m OTS1.verif-key sk)) ⊛ m ⊛ group #m #signature1
                              (concat (map OTS1.sign (group #m #signkey1 sk) ⊛ m))) ≡ 1b
    lemma sk [] = refl
    lemma sk (b ∷ m)
      rewrite (let open lemma sk b m in take-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in drop-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in take-++ #signature1 sigL sigH)
            | (let open lemma sk b m in drop-++ #signature1 sigL sigH)
            | (let open lemma sk b m in OTS1.verify-correct-sig skL b)
            | (let open lemma sk b m in lemma skH m)
            = refl
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Function using (_∘_)
open import Data.Nat.NP hiding (_==_)
open import Data.Product.NP hiding (map)
open import Data.Bit hiding (_==_)
open import Data.Bits
open import Data.Bits.Properties
open import Data.Vec.NP
open import Relation.Binary.PropositionalEquality.NP
import Crypto.Sig.LamportOneBit

module Crypto.Sig.Lamport
          (#digest  : ℕ)
          (#seed    : ℕ)
          (#secret  : ℕ)
          (#message : ℕ)
          (hash-secret    : Bits #secret → Bits #digest)
          (seed-expansion : Bits #seed   → Bits (#message * 2* #secret))
          where

module OTS1 = Crypto.Sig.LamportOneBit #secret #digest hash-secret

H = hash-secret

#signkey1   = OTS1.#signkey
#verifkey1  = OTS1.#verifkey
#signature1 = OTS1.#signature
#signkey    = #message * #signkey1
#verifkey   = #message * #verifkey1
#signature  = #message * #signature1

Digest     = Bits #digest
Seed       = Bits #seed
Secret     = Bits #secret
SignKey    = Bits #signkey
Message    = Bits #message
Signature  = Bits #signature
VerifKey   = Bits #verifkey

verif-key : SignKey → VerifKey
verif-key = map* #message OTS1.verif-key

module verifkey (vk : VerifKey) where
  vk1s = group #message #verifkey1 vk

module signkey (sk : SignKey) where
  sk1s = group #message #signkey1 sk
  vk   = verif-key sk
  open verifkey vk public

module signature (sig : Signature) where
  sig1s = group #message #signature1 sig

key-gen : Seed → VerifKey × SignKey
key-gen s = vk , sk
  module key-gen where
    sk = seed-expansion s
    vk = verif-key sk

sign : SignKey → Message → Signature
sign sk m = sig
  module sign where
    open signkey sk public
    sig1s = map OTS1.sign sk1s ⊛ m
    sig   = concat sig1s

verify : VerifKey → Message → Signature → Bit
verify vk m sig = and (map OTS1.verify vk1s ⊛ m ⊛ sig1s)
  module verify where
    open verifkey  vk  public
    open signature sig public

verify-correct-sig : ∀ sk m → verify (verif-key sk) m (sign sk m) ≡ 1b
verify-correct-sig = lemma
  where
    module lemma {#m} sk b m where
      skL  = take #signkey1 sk
      skH  = drop #signkey1 sk
      vkL  = OTS1.verif-key skL
      vkH  = map* #m OTS1.verif-key skH
      sigL = OTS1.sign skL b
      sigH = concat (map OTS1.sign (group #m #signkey1 skH) ⊛ m)

    lemma : ∀ {#m} sk m → and (map OTS1.verify (group #m #verifkey1 (map* #m OTS1.verif-key sk)) ⊛ m ⊛ group #m #signature1
                               (concat (map OTS1.sign (group #m #signkey1 sk) ⊛ m))) ≡ 1b
    lemma sk [] = refl
    lemma sk (b ∷ m)
      rewrite (let open lemma sk b m in take-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in drop-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in take-++ #signature1 sigL sigH)
            | (let open lemma sk b m in drop-++ #signature1 sigL sigH)
            | (let open lemma sk b m in OTS1.verify-correct-sig skL b)
            | (let open lemma sk b m in lemma skH m)
            = refl
-- -}
-- -}
-- -}
-- -}


Removed unnecessary pragma and parenthesis.

------------------------------------------------------------------------------
-- Definition of FOTC Conat using Agda's co-inductive combinators
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Conat.TypeSL where

open import FOTC.Base
open import Coinduction

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

data Conat : D → Set where
  cozero : Conat zero
  cosucc : ∀ {n} → ∞ (Conat n) → Conat (succ₁ n)

Conat-out : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
Conat-out cozero          = inj₁ refl
Conat-out (cosucc {n} Cn) = inj₂ (n , refl , ♭ Cn)

Conat-in : ∀ {n} →
           n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n') →
           Conat n
Conat-in (inj₁ n≡0)              = subst Conat (sym n≡0) cozero
Conat-in (inj₂ (n' , prf , Cn')) = subst Conat (sym prf) (cosucc (♯ Cn'))

Conat-coind-helper :
  ∀ (A : D → Set) {n} →
  (∀ {m} → A m → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ A m')) →
  A n → Conat n
Conat-coind-helper A h An with h An
... | inj₁ n≡0 = subst Conat (sym n≡0) cozero
... | inj₂ (n' , prf , An') =
  subst Conat (sym prf) (cosucc (♯ (Conat-coind-helper A h An')))

-- 07 January 2014. Agda bug? We couldn't directly prove Conat-coind
-- because Agda's termination checker doesn't accept the proof, but it
-- accepts the proof of Conat-coind-helper. The only difference is the
-- *position* of the universal quantifier ∀ {n}.
Conat-coind : (A : D → Set) →
              (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
              ∀ {n} → A n → Conat n
Conat-coind A h An = Conat-coind-helper A h An

postulate
  ∞D    : D
  ∞-eq : ∞D ≡ succ₁ ∞D

-- TODO (06 January 2014): Agda doesn't accept the proof of Conat ∞.
{-# NO_TERMINATION_CHECK #-}
∞-Conat : Conat ∞D
∞-Conat = subst Conat (sym ∞-eq) (cosucc (♯ ∞-Conat))

------------------------------------------------------------------------------
-- Definition of FOTC Conat using Agda's co-inductive combinators
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Conat.TypeSL where

open import FOTC.Base
open import Coinduction

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

data Conat : D → Set where
  cozero : Conat zero
  cosucc : ∀ {n} → (∞ (Conat n)) → Conat (succ₁ n)

Conat-out : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
Conat-out cozero          = inj₁ refl
Conat-out (cosucc {n} Cn) = inj₂ (n , refl , ♭ Cn)

Conat-in : ∀ {n} →
           n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n') →
           Conat n
Conat-in (inj₁ n≡0)              = subst Conat (sym n≡0) cozero
Conat-in (inj₂ (n' , prf , Cn')) = subst Conat (sym prf) (cosucc (♯ Cn'))

Conat-coind-helper :
  ∀ (A : D → Set) {n} →
  (∀ {m} → A m → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ A m')) →
  A n → Conat n
Conat-coind-helper A h An with h An
... | inj₁ n≡0 = subst Conat (sym n≡0) cozero
... | inj₂ (n' , prf , An') =
  subst Conat (sym prf) (cosucc (♯ (Conat-coind-helper A h An')))

-- 07 January 2014. Agda bug? We couldn't directly prove Conat-coind
-- because Agda's termination checker doesn't accept the proof, but it
-- accepts the proof of Conat-coind-helper. The only difference is the
-- *position* of the universal quantifier ∀ {n}.
Conat-coind : (A : D → Set) →
              (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
              ∀ {n} → A n → Conat n
Conat-coind A h An = Conat-coind-helper A h An

postulate
  ∞D    : D
  ∞-eq : ∞D ≡ succ₁ ∞D

-- TODO (06 January 2014): Agda doesn't accept the proof of Conat ∞.
{-# NO_TERMINATION_CHECK #-}
∞-Conat : Conat ∞D
∞-Conat = subst Conat (sym ∞-eq) (cosucc (♯ ∞-Conat))


Added x≠Sx to inductive PA.

Added x≠Sx to inductive PA.

Ignore-this: 88c8bc1743b92688e1e57667a5472580

darcs-hash:20120303040024-3bd4e-93ad7b3dc9f315fc7d519e8f39c779b33c089493.gz

------------------------------------------------------------------------------
-- Inductive PA properties commons to the interactive and automatic proofs
------------------------------------------------------------------------------

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

module PA.Inductive.Properties where

open import PA.Inductive.Base

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

succ-cong : ∀ {m n} → m ≡ n → succ m ≡ succ n
succ-cong = cong succ

+-leftCong : ∀ {m n o} → m ≡ n → m + o ≡ n + o
+-leftCong h = cong₂ _+_ h refl

-- TODO: It is strictly necessary the implicit argument m?
+-rightCong : ∀ {m n o} → n ≡ o → m + n ≡ m + o
+-rightCong {m} h = cong₂ _+_ {m} refl h

------------------------------------------------------------------------------
-- Peano's third axiom.
P₃ : ∀ {m n} → succ m ≡ succ n → m ≡ n
P₃ refl = refl

-- Peano's fourth axiom.
P₄ : ∀ {n} → ¬ (zero ≡ succ n)
P₄ ()

x≠Sx : ∀ {n} → ¬ (n ≡ succ n)
x≠Sx {zero} ()
x≠Sx {succ n} h = x≠Sx (P₃ h)

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = refl

-- Adapted from the Agda standard library v0.6 (see
-- Data.Nat.Properties.n+0≡n).
+-rightIdentity : ∀ n → n + zero ≡ n
+-rightIdentity zero     = refl
+-rightIdentity (succ n) = succ-cong (+-rightIdentity n)

-- Adapted from the Agda standard library v0.6 (see
-- Data.Nat.Properties.+-assoc).
+-assoc : ∀ m n o → m + n + o ≡ m + (n + o)
+-assoc zero     _ _ = refl
+-assoc (succ m) n o = succ-cong (+-assoc m n o)

-- Adapted from the Agda standard library v0.6 (see
-- Data.Nat.Properties.m+1+n≡1+m+n).
x+Sy≡S[x+y] : ∀ m n → m + succ n ≡ succ (m + n)
x+Sy≡S[x+y] zero     _ = refl
x+Sy≡S[x+y] (succ m) n = succ-cong (x+Sy≡S[x+y] m n)

------------------------------------------------------------------------------
-- Inductive PA properties commons to the interactive and automatic proofs
------------------------------------------------------------------------------

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

module PA.Inductive.Properties where

open import PA.Inductive.Base

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

succ-cong : ∀ {m n} → m ≡ n → succ m ≡ succ n
succ-cong = cong succ

+-leftCong : ∀ {m n o} → m ≡ n → m + o ≡ n + o
+-leftCong h = cong₂ _+_ h refl

-- TODO: It is strictly necessary the implicit argument m?
+-rightCong : ∀ {m n o} → n ≡ o → m + n ≡ m + o
+-rightCong {m} h = cong₂ _+_ {m} refl h

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

-- Peano's third axiom.
P₃ : ∀ {m n} → succ m ≡ succ n → m ≡ n
P₃ refl = refl

-- Peano's fourth axiom.
P₄ : ∀ {n} → ¬ (zero ≡ succ n)
P₄ ()

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = refl

-- Adapted from the Agda standard library v0.6 (see
-- Data.Nat.Properties.n+0≡n).
+-rightIdentity : ∀ n → n + zero ≡ n
+-rightIdentity zero     = refl
+-rightIdentity (succ n) = succ-cong (+-rightIdentity n)

-- Adapted from the Agda standard library v0.6 (see
-- Data.Nat.Properties.+-assoc).
+-assoc : ∀ m n o → m + n + o ≡ m + (n + o)
+-assoc zero     _ _ = refl
+-assoc (succ m) n o = succ-cong (+-assoc m n o)

-- Adapted from the Agda standard library v0.6 (see
-- Data.Nat.Properties.m+1+n≡1+m+n).
x+Sy≡S[x+y] : ∀ m n → m + succ n ≡ succ (m + n)
x+Sy≡S[x+y] zero     _ = refl
x+Sy≡S[x+y] (succ m) n = succ-cong (x+Sy≡S[x+y] m n)


Fixed a draft.

Fixed a draft.

Ignore-this: bf3af2a57414652c34cac96c640f6436

darcs-hash:20120224154216-3bd4e-beeeb1cbd8ae38e8c2f1b9ca78eff7e80ad53f12.gz

------------------------------------------------------------------------------
-- Totality of natural numbers addition
------------------------------------------------------------------------------

-- Tested with magda and agda2atp on 24 February 2012.

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

module Draft.FOTC.Data.Nat.AddTotality where

open import FOTC.Base
open import FOTC.Data.Nat

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

-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = N-ind P P0 ih Nm
  where
    P : D → Set
    P i = N (i + n)

    P0 : P zero
    P0 = subst N (sym (+-0x n)) Nn

    ih : ∀ {i} → P i → P (succ₁ i)
    ih {i} ih = subst N (sym (+-Sx i n)) (sN ih)

-- Combined proof using an instance of the induction principle.
indN-instance : ∀ x →
                N (zero + x) →
                (∀ {n} → N (n + x) → N (succ₁ n + x)) →
                ∀ {n} → N n → N (n + x)
indN-instance x = N-ind (λ i → N (i + x))

postulate
  +-N₁ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₁ indN-instance #-}

-- Combined proof using the induction principle.

-- The translation is
-- ∀ p. app₁(p,zero) →
--      (∀ x. app₁(n,x) → app₁(p,x) → app₁(p,appFn(succ,x))) →   -- indN
--      (∀ x. app₁(n,x) → app₁(p,x))
----------------------------------------------------------------
-- ∀ x y. app₁(n,x) → app₁(n,y) → app₁(n,appFn(appFn(+,x),y))    -- +-N₂

postulate
  +-N₂ : ∀ {m n} → N m → N n → N (m + n)
-- The ATPs could not prove this postulate.
-- {-# ATP prove +-N₂ indN #-}

------------------------------------------------------------------------------
-- Totality of natural numbers addition
------------------------------------------------------------------------------

-- Tested with magda and agda2atp on 15 December 2011.

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

module Draft.FOTC.Data.Nat.AddTotality where

open import FOTC.Base
open import FOTC.Data.Nat

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

-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = indN P P0 ih Nm
  where
    P : D → Set
    P = λ i → N (i + n)

    P0 : P zero
    P0 = subst N (sym (+-0x n)) Nn

    ih : ∀ {i} → P i → P (succ₁ i)
    ih {i} Pi = subst N (sym (+-Sx i n)) (sN Pi)

-- Combined proof using an instance of the induction principle.
indN-instance : ∀ x →
                N (zero + x) →
                (∀ {n} → N (n + x) → N (succ₁ n + x)) →
                ∀ {n} → N n → N (n + x)
indN-instance x = indN (λ i → N (i + x))

postulate
  +-N₁ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₁ indN-instance #-}

-- Combined proof using the induction principle.

-- The translation is
-- ∀ p. app₁(p,zero) →
--      (∀ x. app₁(n,x) → app₁(p,x) → app₁(p,appFn(succ,x))) →   -- indN
--      (∀ x. app₁(n,x) → app₁(p,x))
----------------------------------------------------------------
-- ∀ x y. app₁(n,x) → app₁(n,y) → app₁(n,appFn(appFn(+,x),y))    -- +-N₂

postulate
  +-N₂ : ∀ {m n} → N m → N n → N (m + n)
-- The ATPs could not prove this postulate.
-- {-# ATP prove +-N₂ indN #-}


Updated documentation related to the --no-internal-equality Apia option.

------------------------------------------------------------------------------
-- Axiomatic Peano arithmetic base
------------------------------------------------------------------------------

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

-- Mendelson's axioms for first-order Peano arithmetic [Mendelson,
-- 1977, p. 155].

-- Elliott Mendelson. Introduction to mathematical logic. Chapman &
-- Hall, 4th edition, 1997, p. 155.

-- NB. These axioms formalize the propositional equality.

module PA.Axiomatic.Mendelson.Base where

infixl 7 _*_
infixl 6 _+_
infix  4 _≈_ _≉_

------------------------------------------------------------------------------
-- First-order logic (without equality)
open import Common.FOL.FOL public renaming ( D to ℕ )

-- Non-logical constants
postulate
  zero    : ℕ
  succ    : ℕ → ℕ
  _+_ _*_ : ℕ → ℕ → ℕ

-- The PA equality.
--
-- N.B. We use the symbol _≈_ for avoiding to use the
-- --no-internal-equality Apia option.
postulate _≈_ : ℕ → ℕ → Set

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

-- Proper axioms

-- S₁. m = n → m = o → n = o
-- S₂. m = n → succ m = succ n
-- S₃. 0 ≠ succ n
-- S₄. succ m = succ n → m = n
-- S₅. 0 + n = n
-- S₆. succ m + n = succ (m + n)
-- S₇. 0 * n = 0
-- S₈. succ m * n = (m * n) + n
-- S₉. P(0) → (∀n.P(n) → P(succ n)) → ∀n.P(n), for any wff P(n) of PA.

postulate
  S₁ : ∀ {m n o} → m ≈ n → m ≈ o → n ≈ o
  S₂ : ∀ {m n} → m ≈ n → succ m ≈ succ n
  S₃ : ∀ {n} → zero ≉ succ n
  S₄ : ∀ {m n} → succ m ≈ succ n → m ≈ n
  S₅ : ∀ n → zero + n ≈ n
  S₆ : ∀ m n → succ m + n ≈ succ (m + n)
  S₇ : ∀ n → zero * n ≈ zero
  S₈ : ∀ m n → succ m * n ≈ n + m * n
{-# ATP axiom S₁ S₂ S₃ S₄ S₅ S₆ S₇ S₈ #-}

-- S₉ is an axiom schema, therefore we do not translate it to TPTP.
postulate S₉ : (A : ℕ → Set) → A zero → (∀ n → A n → A (succ n)) → ∀ n → A n

------------------------------------------------------------------------------
-- Axiomatic Peano arithmetic base
------------------------------------------------------------------------------

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

-- Mendelson's axioms for first-order Peano arithmetic [Mendelson,
-- 1977, p. 155].

-- Elliott Mendelson. Introduction to mathematical logic. Chapman &
-- Hall, 4th edition, 1997, p. 155.

-- NB. These axioms formalize the propositional equality.

module PA.Axiomatic.Mendelson.Base where

infixl 7 _*_
infixl 6 _+_
infix  4 _≈_ _≉_

------------------------------------------------------------------------------
-- First-order logic (without equality)
open import Common.FOL.FOL public renaming ( D to ℕ )

-- Non-logical constants
postulate
  zero    : ℕ
  succ    : ℕ → ℕ
  _+_ _*_ : ℕ → ℕ → ℕ

-- The PA equality.
--
-- N.B. The symbol _≡_ should not be used because it is hard-coded by
-- Apia as the ATPs equality.
postulate _≈_ : ℕ → ℕ → Set

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

-- Proper axioms

-- S₁. m = n → m = o → n = o
-- S₂. m = n → succ m = succ n
-- S₃. 0 ≠ succ n
-- S₄. succ m = succ n → m = n
-- S₅. 0 + n = n
-- S₆. succ m + n = succ (m + n)
-- S₇. 0 * n = 0
-- S₈. succ m * n = (m * n) + n
-- S₉. P(0) → (∀n.P(n) → P(succ n)) → ∀n.P(n), for any wff P(n) of PA.

postulate
  S₁ : ∀ {m n o} → m ≈ n → m ≈ o → n ≈ o
  S₂ : ∀ {m n} → m ≈ n → succ m ≈ succ n
  S₃ : ∀ {n} → zero ≉ succ n
  S₄ : ∀ {m n} → succ m ≈ succ n → m ≈ n
  S₅ : ∀ n → zero + n ≈ n
  S₆ : ∀ m n → succ m + n ≈ succ (m + n)
  S₇ : ∀ n → zero * n ≈ zero
  S₈ : ∀ m n → succ m * n ≈ n + m * n
{-# ATP axiom S₁ S₂ S₃ S₄ S₅ S₆ S₇ S₈ #-}

-- S₉ is an axiom schema, therefore we do not translate it to TPTP.
postulate S₉ : (A : ℕ → Set) → A zero → (∀ n → A n → A (succ n)) → ∀ n → A n


Fixed a module name.

Fixed a module name.

Ignore-this: 2f8d900a7574dc6e4dc23bbdcfde511f

darcs-hash:20101011230518-3bd4e-e59e5b05c7009146e06969a61f639da8f6f7dc73.gz

module Notes.FixedPoints.Predicates where

open import LTC.Minimal

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

-- The pure (i.e. non-inductive) LTC natural numbers.
module Pure where
  postulate
    N  : D → Set
    zN : N zero
    sN : {n : D} → N n → N (succ n)

-- The (inductive) LTC natural numbers.
module Inductive where

  data N : D → Set where
    zN : N zero
    sN : {n : D} → N n → N (succ n)

-- The (fixed-point) LTC natural numbers.
module FixedPoint where

  -- Because N is an inductive data type, we can defined it as the least
  -- fixed-point (Fix) of an appropriate functional.
  postulate
    Fix : ((D → Set) → D → Set) → D → Set
    -- In the first-order version of LTC we cannot use the equality on
    -- predicates
    --
    -- (i.e. _≣_ : (D → Set) → (D → Set) → Set),
    --
    -- therefore we postulate both directions of the conversion rule
    -- Fix f = f (Fix f).
    cFix₁ : (f : (D → Set) → D → Set) → (d : D) → Fix f d → f (Fix f) d
    cFix₂ : (f : (D → Set) → D → Set) → (d : D) → f (Fix f) d → Fix f d

  -- From Peter: FN if D was an inductive type
  -- FN : (D → Set) → D → Set
  -- FN X zero     = ⊤
  -- FN X (succ n) = X n

  -- From Peter: FN in pure predicate logic
  FN : (D → Set) → D → Set
  FN X n = n ≡ zero ∨ (∃D (λ m → n ≡ succ m ∧ X m))

  -- The LTC natural numbers using Fix.
  N : D → Set
  N = Fix FN

  -- The data constructors of the inductive version via the
  -- fixed-point version.
  zN : N zero
  zN = cFix₂ FN zero (inj₁ refl)

  sN : {n : D} → N n → N (succ n)
  sN {n} Nn = cFix₂ FN (succ n) (inj₂ (n , (refl , Nn)))

module Others.FixedPoints.Predicates where

open import LTC.Minimal

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

-- The pure (i.e. non-inductive) LTC natural numbers.
module Pure where
  postulate
    N  : D → Set
    zN : N zero
    sN : {n : D} → N n → N (succ n)

-- The (inductive) LTC natural numbers.
module Inductive where

  data N : D → Set where
    zN : N zero
    sN : {n : D} → N n → N (succ n)

-- The (fixed-point) LTC natural numbers.
module FixedPoint where

  -- Because N is an inductive data type, we can defined it as the least
  -- fixed-point (Fix) of an appropriate functional.
  postulate
    Fix : ((D → Set) → D → Set) → D → Set
    -- In the first-order version of LTC we cannot use the equality on
    -- predicates
    --
    -- (i.e. _≣_ : (D → Set) → (D → Set) → Set),
    --
    -- therefore we postulate both directions of the conversion rule
    -- Fix f = f (Fix f).
    cFix₁ : (f : (D → Set) → D → Set) → (d : D) → Fix f d → f (Fix f) d
    cFix₂ : (f : (D → Set) → D → Set) → (d : D) → f (Fix f) d → Fix f d

  -- From Peter: FN if D was an inductive type
  -- FN : (D → Set) → D → Set
  -- FN X zero     = ⊤
  -- FN X (succ n) = X n

  -- From Peter: FN in pure predicate logic
  FN : (D → Set) → D → Set
  FN X n = n ≡ zero ∨ (∃D (λ m → n ≡ succ m ∧ X m))

  -- The LTC natural numbers using Fix.
  N : D → Set
  N = Fix FN

  -- The data constructors of the inductive version via the
  -- fixed-point version.
  zN : N zero
  zN = cFix₂ FN zero (inj₁ refl)

  sN : {n : D} → N n → N (succ n)
  sN {n} Nn = cFix₂ FN (succ n) (inj₂ (n , (refl , Nn)))


Fixed typo.

Fixed typo.

------------------------------------------------------------------------------
-- Definition of FOTC Conat using Agda's co-inductive combinators
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Conat.TypeSL where

open import Coinduction
open import FOTC.Base

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

data Conat : D → Set where
  cozero : Conat zero
  cosucc : ∀ {n} → ∞ (Conat n) → Conat (succ₁ n)

Conat-out : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
Conat-out cozero          = inj₁ refl
Conat-out (cosucc {n} Cn) = inj₂ (n , refl , ♭ Cn)

Conat-in : ∀ {n} →
           n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n') →
           Conat n
Conat-in (inj₁ n≡0)              = subst Conat (sym n≡0) cozero
Conat-in (inj₂ (n' , prf , Cn')) = subst Conat (sym prf) (cosucc (♯ Cn'))

-- 08 January 2014. Fails with --without-K.
Conat-coind : (A : D → Set) →
              (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
              ∀ {n} → A n → Conat n
Conat-coind A h An with h An
... | inj₁ refl = cozero
... | inj₂ (n' , refl , An') = cosucc (♯ (Conat-coind A h An'))

-- TODO (07 January 2014): We couldn't prove Conat-stronger-coind.
Conat-stronger-coind :
  ∀ (A : D → Set) {n} →
  (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  A n → Conat n
Conat-stronger-coind A h An with h An
... | inj₁ n≡0 = subst Conat (sym n≡0) cozero
... | inj₂ (n' , prf , An') =
  subst Conat (sym prf) (cosucc (♯ (Conat-coind A {!!} An')))

postulate
  ∞D    : D
  ∞-eq : ∞D ≡ succ₁ ∞D

-- TODO (06 January 2014): Agda doesn't accept the proof of Conat ∞D.
{-# NO_TERMINATION_CHECK #-}
∞-Conat : Conat ∞D
∞-Conat = subst Conat (sym ∞-eq) (cosucc (♯ ∞-Conat))

------------------------------------------------------------------------------
-- Definition of FOTC Conat using Agda's co-inductive combinators
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Conat.TypeSL where

open import Coinduction
open import FOTC.Base

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

data Conat : D → Set where
  cozero : Conat zero
  cosucc : ∀ {n} → ∞ (Conat n) → Conat (succ₁ n)

Conat-out : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
Conat-out cozero          = inj₁ refl
Conat-out (cosucc {n} Cn) = inj₂ (n , refl , ♭ Cn)

Conat-in : ∀ {n} →
           n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n') →
           Conat n
Conat-in (inj₁ n≡0)              = subst Conat (sym n≡0) cozero
Conat-in (inj₂ (n' , prf , Cn')) = subst Conat (sym prf) (cosucc (♯ Cn'))

-- 08 January 2014. Fails with --without-K.
Conat-coind : (A : D → Set) →
              (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
              ∀ {n} → A n → Conat n
Conat-coind A h An with h An
... | inj₁ refl = cozero
... | inj₂ (n' , refl , An') = cosucc (♯ (Conat-coind A h An'))

-- TODO (07 January 2014): We couldn't prove Conat-stronger-coind.
Conat-stronger-coind :
  ∀ (A : D → Set) {n} →
  (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  A n → Conat n
Conat-stronger-coind A h An with h An
... | inj₁ n≡0 = subst Conat (sym n≡0) cozero
... | inj₂ (n' , prf , An') =
  subst Conat (sym prf) (cosucc (♯ (Conat-coind A {!!} An')))

postulate
  ∞D    : D
  ∞-eq : ∞D ≡ succ₁ ∞D

-- TODO (06 January 2014): Agda doesn't accept the proof of Conat ∞.
{-# NO_TERMINATION_CHECK #-}
∞-Conat : Conat ∞D
∞-Conat = subst Conat (sym ∞-eq) (cosucc (♯ ∞-Conat))


Fin: Fin▹ℕ<

Fin: Fin▹ℕ<

-- NOTE with-K
module Data.Fin.NP where

open import Type hiding (★)
open import Function
open import Data.Zero
open import Data.One using (𝟙)
open import Data.Fin public renaming (toℕ to Fin▹ℕ; fromℕ to ℕ▹Fin)
open import Data.Nat.NP using (ℕ; zero; suc; _<=_; module ℕ°; z≤n; s≤s) renaming (_+_ to _+ℕ_; _<_ to _<ℕ_)
open import Data.Two using (𝟚; 0₂; 1₂; [0:_1:_]; case_0:_1:_)
import Data.Vec.NP as Vec
open Vec using (Vec; []; _∷_; _∷ʳ_; allFin; lookup; rot₁; tabulate; foldr) renaming (map to vmap)
import Data.Vec.Properties as Vec
open import Data.Maybe.NP
open import Data.Sum as Sum
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Binary.PropositionalEquality as ≡

suc-injective : ∀ {m}{i j : Fin m} → Fin.suc i ≡ suc j → i ≡ j
suc-injective refl = refl

pattern #0 = zero
pattern #1 = suc #0
pattern #2 = suc #1
pattern #3 = suc #2
pattern #4 = suc #3
pattern #5 = suc #4
pattern #6 = suc #5
pattern #7 = suc #6
pattern #8 = suc #7
pattern #9 = suc #8
pattern #A = suc #9
pattern #B = suc #A
pattern #C = suc #B
pattern #D = suc #C
pattern #E = suc #D
pattern #F = suc #E

pattern #1+ x = suc x
pattern #2+ x = suc (#1+ x)
pattern #3+ x = suc (#2+ x)
pattern #4+ x = suc (#3+ x)
pattern #5+ x = suc (#4+ x)
pattern #6+ x = suc (#5+ x)
pattern #7+ x = suc (#6+ x)
pattern #8+ x = suc (#7+ x)
pattern #9+ x = suc (#8+ x)
pattern #A+ x = suc (#9+ x)
pattern #B+ x = suc (#A+ x)
pattern #C+ x = suc (#B+ x)
pattern #D+ x = suc (#C+ x)
pattern #E+ x = suc (#D+ x)
pattern #F+ x = suc (#E+ x)

-- The isomorphisms about Fin, 𝟘, 𝟙, 𝟚 are in Function.Related.TypeIsomorphisms.NP

Fin▹𝟘 : Fin 0 → 𝟘
Fin▹𝟘 ()

𝟘▹Fin : 𝟘 → Fin 0
𝟘▹Fin ()

Fin▹𝟙 : Fin 1 → 𝟙
Fin▹𝟙 _ = _

𝟙▹Fin : 𝟙 → Fin 1
𝟙▹Fin _ = zero

Fin▹𝟚 : Fin 2 → 𝟚
Fin▹𝟚 zero    = 0₂
Fin▹𝟚 (suc _) = 1₂

𝟚▹Fin : 𝟚 → Fin 2
𝟚▹Fin = [0: # 0 1: # 1 ]

[zero:_,suc:_] : ∀ {n a}{A : Fin (suc n) → Set a}
                   (z : A zero)(s : (x : Fin n) → A (suc x))
                   (x : Fin (suc n)) → A x
[zero: z ,suc: s ] zero    = z
[zero: z ,suc: s ] (suc x) = s x

_+′_ : ∀ {m n} (x : Fin m) (y : Fin n) → Fin (m +ℕ n)
_+′_ {suc m} {n} zero y rewrite ℕ°.+-comm (suc m) n = inject+ _ y
suc x +′ y = suc (x +′ y)

_≟_ : ∀ {n} (i j : Fin n) → Dec (i ≡ j)
zero ≟ zero = yes refl
zero ≟ suc j = no (λ())
suc i ≟ zero = no (λ())
suc i ≟ suc j with i ≟ j
suc i ≟ suc j | yes p = yes (cong suc p)
suc i ≟ suc j | no ¬p = no (¬p ∘ suc-injective)

_==_ : ∀ {n} (x y : Fin n) → 𝟚
x == y = ⌊ x ≟ y ⌋
{-helper (compare x y) where
  helper : ∀ {n} {i j : Fin n} → Ordering i j → 𝟚
  helper (equal _) = 1₂
  helper _         = 0₂-}

Fin▹ℕ< : ∀{y}(x : Fin y) → Fin▹ℕ x <ℕ y
Fin▹ℕ< zero = s≤s z≤n
Fin▹ℕ< (suc i) = s≤s (Fin▹ℕ< i)

swap : ∀ {i} (x y : Fin i) → Fin i → Fin i
swap x y z = case x == z 0: (case y == z 0: z 1: x) 1: y

module _ {a} {A : ★ a}
         (B : ℕ → ★₀)
         (_◅_ : ∀ {n} → A → B n → B (suc n))
         (ε : B zero) where
  iterate : ∀ {n} (f : Fin n → A) → B n
  iterate {zero}  f = ε
  iterate {suc n} f = f zero ◅ iterate (f ∘ suc)

  iterate-foldr∘tabulate :
    ∀ {n} (f : Fin n → A) → iterate f ≡ foldr B _◅_ ε (tabulate f)
  iterate-foldr∘tabulate {zero} f = refl
  iterate-foldr∘tabulate {suc n} f = cong (_◅_ (f zero)) (iterate-foldr∘tabulate (f ∘ suc))

module _ {a} {A : ★ a} (B : ★₀)
         (_◅_ : A → B → B)
         (ε : B) where
  iterate′ : ∀ {n} (f : Fin n → A) → B
  iterate′ f = iterate _ _◅_ ε f

data FinSum m n : Fin (m +ℕ n) → ★₀ where
  bound : (x : Fin m) → FinSum m n (inject+ n x)
  free  : (x : Fin n) → FinSum m n (raise m x)

open import Relation.Binary.PropositionalEquality

cmp : ∀ m n (x : Fin (m +ℕ n)) → FinSum m n x
cmp zero n x = free x
cmp (suc m) n zero = bound zero
cmp (suc m) n (suc x) with cmp m n x
cmp (suc m) n (suc .(inject+ n x)) | bound x = bound (suc x)
cmp (suc m) n (suc .(raise m x))   | free x  = free x

max : ∀ n → Fin (suc n)
max = ℕ▹Fin

-- reverse x = n ∸ (1 + x)
reverse : ∀ {n} → Fin n → Fin n
reverse {suc n} zero    = ℕ▹Fin n
reverse {suc n} (suc x) = inject₁ (reverse {n} x)

open import Data.Nat
open import Data.Nat.Properties
open import Data.Fin.Properties renaming (reverse to reverse-old)

reverse-fromℕ : ∀ n → reverse (ℕ▹Fin n) ≡ zero
reverse-fromℕ zero = refl
reverse-fromℕ (suc n) rewrite reverse-fromℕ n = refl

reverse-inject₁ : ∀ {n} (x : Fin n) → reverse (inject₁ x) ≡ suc (reverse x)
reverse-inject₁ zero = refl
reverse-inject₁ (suc x) rewrite reverse-inject₁ x = refl

{-
reverse-involutive : ∀ {n} (x : Fin n) → reverse (reverse x) ≡ x
reverse-involutive zero = reverse-fromℕ _
reverse-involutive (suc x) rewrite reverse-inject₁ (reverse x) | reverse-involutive x = refl
-}

reverse-lem : ∀ {n} (x : Fin n) → Fin▹ℕ (reverse x) ≡ n ∸ suc (Fin▹ℕ x)
reverse-lem zero = to-from _
reverse-lem (suc x) rewrite inject₁-lemma (reverse x) = reverse-lem x

Fin▹ℕ-ℕ-lem : ∀ {n} (x : Fin (suc n)) → Fin▹ℕ (n ℕ- x) ≡ n ∸ Fin▹ℕ x
Fin▹ℕ-ℕ-lem zero = to-from _
Fin▹ℕ-ℕ-lem {zero} (suc ())
Fin▹ℕ-ℕ-lem {suc n} (suc x) = Fin▹ℕ-ℕ-lem x

reverse-old-lem : ∀ {n} (x : Fin n) → Fin▹ℕ (reverse-old x) ≡ n ∸ suc (Fin▹ℕ x)
reverse-old-lem {zero} ()
reverse-old-lem {suc n} x rewrite inject≤-lemma (n ℕ- x) (n∸m≤n (Fin▹ℕ x) (suc n)) = Fin▹ℕ-ℕ-lem x

data FinView {n} : Fin (suc n) → ★₀ where
  `fromℕ   : FinView (ℕ▹Fin n)
  `inject₁ : ∀ x → FinView (inject₁ x)

sucFinView : ∀ {n} {i : Fin (suc n)} → FinView i → FinView (suc i)
sucFinView `fromℕ = `fromℕ
sucFinView (`inject₁ x) = `inject₁ (suc x)

finView : ∀ {n} → (i : Fin (suc n)) → FinView i
finView {zero}  zero    = `fromℕ
finView {suc n} zero    = `inject₁ zero
finView {suc n} (suc i) = sucFinView (finView i)
finView {zero}  (suc ())

module Modulo where
  modq : ∀ {q} → Fin (suc q) → Maybe (Fin q)
  modq {zero}  _       = nothing
  modq {suc q} zero    = just zero
  modq {suc q} (suc x) = map? suc (modq x)

  modq-inj : ∀ {q} (i j : Fin (suc q)) → modq i ≡ modq j → i ≡ j
  modq-inj {zero} zero zero eq = refl
  modq-inj {zero} zero (suc ()) eq
  modq-inj {zero} (suc ()) zero eq
  modq-inj {zero} (suc ()) (suc ()) eq
  modq-inj {suc q} zero zero eq = refl
  modq-inj {suc q} zero (suc j) eq with modq j
  modq-inj {suc q} zero (suc j) () | nothing
  modq-inj {suc q} zero (suc j) () | just j'
  modq-inj {suc q} (suc i) zero eq with modq i
  modq-inj {suc q} (suc i) zero () | just x
  modq-inj {suc q} (suc i) zero () | nothing
  modq-inj {suc q} (suc i) (suc j) eq with modq i | modq j | modq-inj i j
  modq-inj {suc q} (suc i) (suc j) eq | just x | just x₁ | p = cong suc (p (cong just (suc-injective (just-injective eq))))
  modq-inj {suc q} (suc i) (suc j) () | just x | nothing | p
  modq-inj {suc q} (suc i) (suc j) () | nothing | just x | p
  modq-inj {suc q} (suc i) (suc j) eq | nothing | nothing | p = cong suc (p refl)

  modq′ : ∀ {q} → Fin (suc q) → Fin (suc q)
  modq′ {zero}  _       = zero
  modq′ {suc q} zero    = suc zero
  modq′ {suc q} (suc x) = lift 1 suc (modq′ x)

  modqq : ∀ {q} → Fin q → Fin q
  modqq {zero}  x = x
  modqq {suc q} x = modq′ x

  -- Maybe (Fin n) ≅ Fin (suc n)

  modq′′ : ∀ {q} → Fin (suc q) → Maybe (Fin q)
  modq′′ x with modq′ x
  ... | zero  = nothing
  ... | suc y = just y

  zero∃ : ∀ {q} → Fin q → Fin q
  zero∃ {zero}  ()
  zero∃ {suc q} _  = zero

  sucmod : ∀ {q} → Fin q → Fin q
  sucmod x with modq (suc x)
  ... | nothing = zero∃ x
  ... | just y  = y

  modq-suc : ∀ {q} (i j : Fin q) → modq (suc i) ≢ just (zero∃ j)
  modq-suc {zero} () () eq
  modq-suc {suc q} i j eq with modq i
  modq-suc {suc q} i j () | just x
  modq-suc {suc q} i j () | nothing

  sucmod-inj : ∀ {q}{i j : Fin q} → sucmod i ≡ sucmod j → i ≡ j
  sucmod-inj {i = i} {j} eq with modq (suc i) | modq (suc j) | modq-inj (suc i) (suc j) | modq-suc i j | modq-suc j i
  sucmod-inj eq | just _  | just _  | p | _ | _ = suc-injective (p (cong just eq))
  sucmod-inj eq | nothing | nothing | p | _ | _ = suc-injective (p refl)
  sucmod-inj eq | just _  | nothing | _ | p | _ = 𝟘-elim (p (cong Maybe.just eq))
  sucmod-inj eq | nothing | just _  | _ | _ | p = 𝟘-elim (p (cong Maybe.just (sym eq)))

  modq-fromℕ : ∀ q → modq (ℕ▹Fin q) ≡ nothing
  modq-fromℕ zero = refl
  modq-fromℕ (suc q) rewrite modq-fromℕ q = refl

  modq-inject₁ : ∀ {q} (i : Fin q) → modq (inject₁ i) ≡ just i
  modq-inject₁ zero = refl
  modq-inject₁ (suc i) rewrite modq-inject₁ i = refl

  sucmod-fromℕ : ∀ q → sucmod (ℕ▹Fin q) ≡ zero
  sucmod-fromℕ q rewrite modq-fromℕ q = refl

  sucmod-inject₁ : ∀ {n} (i : Fin n) → sucmod (inject₁ i) ≡ suc i
  sucmod-inject₁ i rewrite modq-inject₁ i = refl

  lem-inject₁ : ∀ {n a} {A : ★ a} (i : Fin n) (xs : Vec A n) x → lookup (inject₁ i) (xs ∷ʳ x) ≡ lookup i xs
  lem-inject₁ zero    (x₀ ∷ xs) x₁ = refl
  lem-inject₁ (suc i) (x₀ ∷ xs) x₁ = lem-inject₁ i xs x₁

  lem-fromℕ : ∀ {n a} {A : ★ a} (xs : Vec A n) x → lookup (ℕ▹Fin n) (xs ∷ʳ x) ≡ x
  lem-fromℕ {zero}  []       x = refl
  lem-fromℕ {suc n} (_ ∷ xs) x = lem-fromℕ xs x

  lookup-sucmod : ∀ {n a} {A : ★ a} (i : Fin (suc n)) (x : A) xs
                 → lookup i (xs ∷ʳ x) ≡ lookup (sucmod i) (x ∷ xs)
  lookup-sucmod i x xs with finView i
  lookup-sucmod {n} .(ℕ▹Fin n) x xs | `fromℕ rewrite sucmod-fromℕ n = lem-fromℕ xs x
  lookup-sucmod .(inject₁ x) x₁ xs | `inject₁ x rewrite sucmod-inject₁ x = lem-inject₁ x xs x₁

  lookup-map : ∀ {n a b} {A : ★ a} {B : ★ b} (f : A → B) i (xs : Vec A n)
               → lookup i (vmap f xs) ≡ f (lookup i xs)
  lookup-map f zero    (x ∷ xs) = refl
  lookup-map f (suc i) (x ∷ xs) = lookup-map f i xs

  vec≗⇒≡ : ∀ {n a} {A : ★ a} (xs ys : Vec A n) → flip lookup xs ≗ flip lookup ys → xs ≡ ys
  vec≗⇒≡ []       []       _ = refl
  vec≗⇒≡ (x ∷ xs) (y ∷ ys) p rewrite vec≗⇒≡ xs ys (p ∘ suc) | p zero = refl

  -- most likely this is subsumed by the StableUnderInjection parts
  private
     module Unused where
        lookup-sucmod-rot₁ : ∀ {n a} {A : ★ a} (i : Fin n) (xs : Vec A n)
                       → lookup i (rot₁ xs) ≡ lookup (sucmod i) xs
        lookup-sucmod-rot₁ {zero} () xs
        lookup-sucmod-rot₁ {suc n} i (x ∷ xs) = lookup-sucmod i x xs

        lookup-rot₁-allFin : ∀ {n} i → lookup i (rot₁ (allFin n)) ≡ lookup i (vmap sucmod (allFin n))
        lookup-rot₁-allFin {n} i rewrite lookup-sucmod-rot₁ i (allFin _)
                                       | Vec.lookup-allFin (sucmod i)
                                       | lookup-map sucmod i (allFin n)
                                       | Vec.lookup∘tabulate id i
                                       = refl

        rot₁-map-sucmod : ∀ n → rot₁ (allFin n) ≡ vmap sucmod (allFin n)
        rot₁-map-sucmod _ = vec≗⇒≡ _ _ lookup-rot₁-allFin

  {-

  -- -}
  -- -}
  -- -}
  -- -}
  -- -}

-- NOTE with-K
module Data.Fin.NP where

open import Type hiding (★)
open import Function
open import Data.Zero
open import Data.One using (𝟙)
open import Data.Fin public renaming (toℕ to Fin▹ℕ; fromℕ to ℕ▹Fin)
open import Data.Nat.NP using (ℕ; zero; suc; _<=_; module ℕ°) renaming (_+_ to _+ℕ_)
open import Data.Two using (𝟚; 0₂; 1₂; [0:_1:_]; case_0:_1:_)
import Data.Vec.NP as Vec
open Vec using (Vec; []; _∷_; _∷ʳ_; allFin; lookup; rot₁; tabulate; foldr) renaming (map to vmap)
import Data.Vec.Properties as Vec
open import Data.Maybe.NP
open import Data.Sum as Sum
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Binary.PropositionalEquality as ≡

suc-injective : ∀ {m}{i j : Fin m} → Fin.suc i ≡ suc j → i ≡ j
suc-injective refl = refl

-- The isomorphisms about Fin, 𝟘, 𝟙, 𝟚 are in Function.Related.TypeIsomorphisms.NP

Fin▹𝟘 : Fin 0 → 𝟘
Fin▹𝟘 ()

𝟘▹Fin : 𝟘 → Fin 0
𝟘▹Fin ()

Fin▹𝟙 : Fin 1 → 𝟙
Fin▹𝟙 _ = _

𝟙▹Fin : 𝟙 → Fin 1
𝟙▹Fin _ = zero

Fin▹𝟚 : Fin 2 → 𝟚
Fin▹𝟚 zero    = 0₂
Fin▹𝟚 (suc _) = 1₂

𝟚▹Fin : 𝟚 → Fin 2
𝟚▹Fin = [0: # 0 1: # 1 ]

[zero:_,suc:_] : ∀ {n a}{A : Fin (suc n) → Set a}
                   (z : A zero)(s : (x : Fin n) → A (suc x))
                   (x : Fin (suc n)) → A x
[zero: z ,suc: s ] zero    = z
[zero: z ,suc: s ] (suc x) = s x

_+′_ : ∀ {m n} (x : Fin m) (y : Fin n) → Fin (m +ℕ n)
_+′_ {suc m} {n} zero y rewrite ℕ°.+-comm (suc m) n = inject+ _ y
suc x +′ y = suc (x +′ y)

_≟_ : ∀ {n} (i j : Fin n) → Dec (i ≡ j)
zero ≟ zero = yes refl
zero ≟ suc j = no (λ())
suc i ≟ zero = no (λ())
suc i ≟ suc j with i ≟ j
suc i ≟ suc j | yes p = yes (cong suc p)
suc i ≟ suc j | no ¬p = no (¬p ∘ suc-injective)

_==_ : ∀ {n} (x y : Fin n) → 𝟚
x == y = ⌊ x ≟ y ⌋
{-helper (compare x y) where
  helper : ∀ {n} {i j : Fin n} → Ordering i j → 𝟚
  helper (equal _) = 1₂
  helper _         = 0₂-}

swap : ∀ {i} (x y : Fin i) → Fin i → Fin i
swap x y z = case x == z 0: (case y == z 0: z 1: x) 1: y

module _ {a} {A : ★ a}
         (B : ℕ → ★₀)
         (_◅_ : ∀ {n} → A → B n → B (suc n))
         (ε : B zero) where
  iterate : ∀ {n} (f : Fin n → A) → B n
  iterate {zero}  f = ε
  iterate {suc n} f = f zero ◅ iterate (f ∘ suc)

  iterate-foldr∘tabulate :
    ∀ {n} (f : Fin n → A) → iterate f ≡ foldr B _◅_ ε (tabulate f)
  iterate-foldr∘tabulate {zero} f = refl
  iterate-foldr∘tabulate {suc n} f = cong (_◅_ (f zero)) (iterate-foldr∘tabulate (f ∘ suc))

module _ {a} {A : ★ a} (B : ★₀)
         (_◅_ : A → B → B)
         (ε : B) where
  iterate′ : ∀ {n} (f : Fin n → A) → B
  iterate′ f = iterate _ _◅_ ε f

data FinSum m n : Fin (m +ℕ n) → ★₀ where
  bound : (x : Fin m) → FinSum m n (inject+ n x)
  free  : (x : Fin n) → FinSum m n (raise m x)

open import Relation.Binary.PropositionalEquality

cmp : ∀ m n (x : Fin (m +ℕ n)) → FinSum m n x
cmp zero n x = free x
cmp (suc m) n zero = bound zero
cmp (suc m) n (suc x) with cmp m n x
cmp (suc m) n (suc .(inject+ n x)) | bound x = bound (suc x)
cmp (suc m) n (suc .(raise m x))   | free x  = free x

max : ∀ n → Fin (suc n)
max = ℕ▹Fin

-- reverse x = n ∸ (1 + x)
reverse : ∀ {n} → Fin n → Fin n
reverse {suc n} zero    = ℕ▹Fin n
reverse {suc n} (suc x) = inject₁ (reverse {n} x)

open import Data.Nat
open import Data.Nat.Properties
open import Data.Fin.Properties renaming (reverse to reverse-old)

reverse-fromℕ : ∀ n → reverse (ℕ▹Fin n) ≡ zero
reverse-fromℕ zero = refl
reverse-fromℕ (suc n) rewrite reverse-fromℕ n = refl

reverse-inject₁ : ∀ {n} (x : Fin n) → reverse (inject₁ x) ≡ suc (reverse x)
reverse-inject₁ zero = refl
reverse-inject₁ (suc x) rewrite reverse-inject₁ x = refl

{-
reverse-involutive : ∀ {n} (x : Fin n) → reverse (reverse x) ≡ x
reverse-involutive zero = reverse-fromℕ _
reverse-involutive (suc x) rewrite reverse-inject₁ (reverse x) | reverse-involutive x = refl
-}

reverse-lem : ∀ {n} (x : Fin n) → Fin▹ℕ (reverse x) ≡ n ∸ suc (Fin▹ℕ x)
reverse-lem zero = to-from _
reverse-lem (suc x) rewrite inject₁-lemma (reverse x) = reverse-lem x

Fin▹ℕ-ℕ-lem : ∀ {n} (x : Fin (suc n)) → Fin▹ℕ (n ℕ- x) ≡ n ∸ Fin▹ℕ x
Fin▹ℕ-ℕ-lem zero = to-from _
Fin▹ℕ-ℕ-lem {zero} (suc ())
Fin▹ℕ-ℕ-lem {suc n} (suc x) = Fin▹ℕ-ℕ-lem x

reverse-old-lem : ∀ {n} (x : Fin n) → Fin▹ℕ (reverse-old x) ≡ n ∸ suc (Fin▹ℕ x)
reverse-old-lem {zero} ()
reverse-old-lem {suc n} x rewrite inject≤-lemma (n ℕ- x) (n∸m≤n (Fin▹ℕ x) (suc n)) = Fin▹ℕ-ℕ-lem x

data FinView {n} : Fin (suc n) → ★₀ where
  `fromℕ   : FinView (ℕ▹Fin n)
  `inject₁ : ∀ x → FinView (inject₁ x)

sucFinView : ∀ {n} {i : Fin (suc n)} → FinView i → FinView (suc i)
sucFinView `fromℕ = `fromℕ
sucFinView (`inject₁ x) = `inject₁ (suc x)

finView : ∀ {n} → (i : Fin (suc n)) → FinView i
finView {zero}  zero    = `fromℕ
finView {suc n} zero    = `inject₁ zero
finView {suc n} (suc i) = sucFinView (finView i)
finView {zero}  (suc ())

module Modulo where
  modq : ∀ {q} → Fin (suc q) → Maybe (Fin q)
  modq {zero}  _       = nothing
  modq {suc q} zero    = just zero
  modq {suc q} (suc x) = map? suc (modq x)

  modq-inj : ∀ {q} (i j : Fin (suc q)) → modq i ≡ modq j → i ≡ j
  modq-inj {zero} zero zero eq = refl
  modq-inj {zero} zero (suc ()) eq
  modq-inj {zero} (suc ()) zero eq
  modq-inj {zero} (suc ()) (suc ()) eq
  modq-inj {suc q} zero zero eq = refl
  modq-inj {suc q} zero (suc j) eq with modq j
  modq-inj {suc q} zero (suc j) () | nothing
  modq-inj {suc q} zero (suc j) () | just j'
  modq-inj {suc q} (suc i) zero eq with modq i
  modq-inj {suc q} (suc i) zero () | just x
  modq-inj {suc q} (suc i) zero () | nothing
  modq-inj {suc q} (suc i) (suc j) eq with modq i | modq j | modq-inj i j
  modq-inj {suc q} (suc i) (suc j) eq | just x | just x₁ | p = cong suc (p (cong just (suc-injective (just-injective eq))))
  modq-inj {suc q} (suc i) (suc j) () | just x | nothing | p
  modq-inj {suc q} (suc i) (suc j) () | nothing | just x | p
  modq-inj {suc q} (suc i) (suc j) eq | nothing | nothing | p = cong suc (p refl)

  modq′ : ∀ {q} → Fin (suc q) → Fin (suc q)
  modq′ {zero}  _       = zero
  modq′ {suc q} zero    = suc zero
  modq′ {suc q} (suc x) = lift 1 suc (modq′ x)

  modqq : ∀ {q} → Fin q → Fin q
  modqq {zero}  x = x
  modqq {suc q} x = modq′ x

  -- Maybe (Fin n) ≅ Fin (suc n)

  modq′′ : ∀ {q} → Fin (suc q) → Maybe (Fin q)
  modq′′ x with modq′ x
  ... | zero  = nothing
  ... | suc y = just y

  zero∃ : ∀ {q} → Fin q → Fin q
  zero∃ {zero}  ()
  zero∃ {suc q} _  = zero

  sucmod : ∀ {q} → Fin q → Fin q
  sucmod x with modq (suc x)
  ... | nothing = zero∃ x
  ... | just y  = y

  modq-suc : ∀ {q} (i j : Fin q) → modq (suc i) ≢ just (zero∃ j)
  modq-suc {zero} () () eq
  modq-suc {suc q} i j eq with modq i
  modq-suc {suc q} i j () | just x
  modq-suc {suc q} i j () | nothing

  sucmod-inj : ∀ {q}{i j : Fin q} → sucmod i ≡ sucmod j → i ≡ j
  sucmod-inj {i = i} {j} eq with modq (suc i) | modq (suc j) | modq-inj (suc i) (suc j) | modq-suc i j | modq-suc j i
  sucmod-inj eq | just _  | just _  | p | _ | _ = suc-injective (p (cong just eq))
  sucmod-inj eq | nothing | nothing | p | _ | _ = suc-injective (p refl)
  sucmod-inj eq | just _  | nothing | _ | p | _ = 𝟘-elim (p (cong Maybe.just eq))
  sucmod-inj eq | nothing | just _  | _ | _ | p = 𝟘-elim (p (cong Maybe.just (sym eq)))

  modq-fromℕ : ∀ q → modq (ℕ▹Fin q) ≡ nothing
  modq-fromℕ zero = refl
  modq-fromℕ (suc q) rewrite modq-fromℕ q = refl

  modq-inject₁ : ∀ {q} (i : Fin q) → modq (inject₁ i) ≡ just i
  modq-inject₁ zero = refl
  modq-inject₁ (suc i) rewrite modq-inject₁ i = refl

  sucmod-fromℕ : ∀ q → sucmod (ℕ▹Fin q) ≡ zero
  sucmod-fromℕ q rewrite modq-fromℕ q = refl

  sucmod-inject₁ : ∀ {n} (i : Fin n) → sucmod (inject₁ i) ≡ suc i
  sucmod-inject₁ i rewrite modq-inject₁ i = refl

  lem-inject₁ : ∀ {n a} {A : ★ a} (i : Fin n) (xs : Vec A n) x → lookup (inject₁ i) (xs ∷ʳ x) ≡ lookup i xs
  lem-inject₁ zero    (x₀ ∷ xs) x₁ = refl
  lem-inject₁ (suc i) (x₀ ∷ xs) x₁ = lem-inject₁ i xs x₁

  lem-fromℕ : ∀ {n a} {A : ★ a} (xs : Vec A n) x → lookup (ℕ▹Fin n) (xs ∷ʳ x) ≡ x
  lem-fromℕ {zero}  []       x = refl
  lem-fromℕ {suc n} (_ ∷ xs) x = lem-fromℕ xs x

  lookup-sucmod : ∀ {n a} {A : ★ a} (i : Fin (suc n)) (x : A) xs
                 → lookup i (xs ∷ʳ x) ≡ lookup (sucmod i) (x ∷ xs)
  lookup-sucmod i x xs with finView i
  lookup-sucmod {n} .(ℕ▹Fin n) x xs | `fromℕ rewrite sucmod-fromℕ n = lem-fromℕ xs x
  lookup-sucmod .(inject₁ x) x₁ xs | `inject₁ x rewrite sucmod-inject₁ x = lem-inject₁ x xs x₁

  lookup-map : ∀ {n a b} {A : ★ a} {B : ★ b} (f : A → B) i (xs : Vec A n)
               → lookup i (vmap f xs) ≡ f (lookup i xs)
  lookup-map f zero    (x ∷ xs) = refl
  lookup-map f (suc i) (x ∷ xs) = lookup-map f i xs

  vec≗⇒≡ : ∀ {n a} {A : ★ a} (xs ys : Vec A n) → flip lookup xs ≗ flip lookup ys → xs ≡ ys
  vec≗⇒≡ []       []       _ = refl
  vec≗⇒≡ (x ∷ xs) (y ∷ ys) p rewrite vec≗⇒≡ xs ys (p ∘ suc) | p zero = refl

  -- most likely this is subsumed by the StableUnderInjection parts
  private
     module Unused where
        lookup-sucmod-rot₁ : ∀ {n a} {A : ★ a} (i : Fin n) (xs : Vec A n)
                       → lookup i (rot₁ xs) ≡ lookup (sucmod i) xs
        lookup-sucmod-rot₁ {zero} () xs
        lookup-sucmod-rot₁ {suc n} i (x ∷ xs) = lookup-sucmod i x xs

        lookup-rot₁-allFin : ∀ {n} i → lookup i (rot₁ (allFin n)) ≡ lookup i (vmap sucmod (allFin n))
        lookup-rot₁-allFin {n} i rewrite lookup-sucmod-rot₁ i (allFin _)
                                       | Vec.lookup-allFin (sucmod i)
                                       | lookup-map sucmod i (allFin n)
                                       | Vec.lookup∘tabulate id i
                                       = refl

        rot₁-map-sucmod : ∀ n → rot₁ (allFin n) ≡ vmap sucmod (allFin n)
        rot₁-map-sucmod _ = vec≗⇒≡ _ _ lookup-rot₁-allFin

  {-

  -- -}
  -- -}
  -- -}
  -- -}
  -- -}


Fixed indentation.

Fixed indentation.

------------------------------------------------------------------------------
-- The alternating bit protocol (ABP) satisfies the specification
------------------------------------------------------------------------------

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

-- This module proves the correctness of the ABP following the
-- formalization in [1].

-- [1] Peter Dybjer and Herbert Sander. A functional programming
--     approach to the specification and verification of concurrent
--     systems. Formal Aspects of Computing, 1:303–319, 1989.

module FOTC.Program.ABP.ProofSpecificationI where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesI
open import FOTC.Data.Stream
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair
open import FOTC.Program.ABP.Lemma1I
open import FOTC.Program.ABP.Lemma2I
open import FOTC.Program.ABP.Terms
open import FOTC.Relation.Binary.Bisimilarity

------------------------------------------------------------------------------
-- Main theorem.
spec : ∀ {b is os₀ os₁} → Bit b → Stream is → Fair os₀ → Fair os₁ →
       is ≈ abpTransfer b os₀ os₁ is
spec {b} {is} {os₀} {os₁} Bb Sis Fos₀ Fos₁ = ≈-coind B prf₁ prf₂
  where
  prf₁ : ∀ {is js} → B is js →
         ∃[ i' ] ∃[ is' ] ∃[ js' ] is ≡ i' ∷ is' ∧ js ≡ i' ∷ js' ∧ B is' js'
  prf₁ {is} {js} (b , os₀ , os₁ , as , bs , cs , ds , Sis , Bb , Fos₀ , Fos₁ , h)
     with Stream-unf Sis
  ... | (i' , is' , is≡i'∷is , Sis') =
    i' , is' , js' , is≡i'∷is , js≡i'∷js' , Bis'js'
    where
    ABP-helper : is ≡ i' ∷ is' →
                 ABP b is os₀ os₁ as bs cs ds js →
                 ABP b (i' ∷ is') os₀ os₁ as bs cs ds js
    ABP-helper h₁ h₂ = subst (λ t → ABP b t os₀ os₁ as bs cs ds js) h₁ h₂

    ABP'-lemma₁ : ∃[ os₀' ] ∃[ os₁' ] ∃[ as' ] ∃[ bs' ] ∃[ cs' ] ∃[ ds' ] ∃[ js' ]
                    Fair os₀'
                    ∧ Fair os₁'
                    ∧ ABP' b i' is' os₀' os₁' as' bs' cs' ds' js'
                    ∧ js ≡ i' ∷ js'
    ABP'-lemma₁ = lemma₁ Bb Fos₀ Fos₁ (ABP-helper is≡i'∷is h)

    -- Following Martin Escardo advice (see Agda mailing list, heap
    -- mistery) we use pattern matching instead of ∃ eliminators to
    -- project the elements of the existentials.

    -- 2011-08-25 update: It does not seems strictly necessary because
    -- the Agda issue 415 was fixed.

    js' : D
    js' with ABP'-lemma₁
    ... | _ , _ , _ , _ , _ , _ , js' , _ = js'

    js≡i'∷js' : js ≡ i' ∷ js'
    js≡i'∷js' with ABP'-lemma₁
    ... | _ , _ , _ , _ , _ , _ , _ , _ , _ , _ , h = h

    ABP-lemma₂ : ∃[ os₀'' ] ∃[ os₁'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
                   Fair os₀''
                   ∧ Fair os₁''
                   ∧ ABP (not b) is' os₀'' os₁'' as'' bs'' cs'' ds'' js'
    ABP-lemma₂ with ABP'-lemma₁
    ABP-lemma₂ | _ , _ , _ , _ , _ , _ , _ , Fos₀' , Fos₁' , abp' , _ =
      lemma₂ Bb Fos₀' Fos₁' abp'

    Bis'js' : B is' js'
    Bis'js' with ABP-lemma₂
    ... | os₀'' , os₁'' , as'' , bs'' , cs'' , ds'' , Fos₀'' , Fos₁'' , abp =
      not b , os₀'' , os₁'' , as'' , bs'' , cs'' , ds''
      , Sis' , not-Bool Bb , Fos₀'' , Fos₁'' , abp

  prf₂ : B is (abpTransfer b os₀ os₁ is)
  prf₂ = b
       , os₀
       , os₁
       , has a₁ a₂ a₃ a₄ a₅ is
       , hbs a₁ a₂ a₃ a₄ a₅ is
       , hcs a₁ a₂ a₃ a₄ a₅ is
       , hds a₁ a₂ a₃ a₄ a₅ is
       , Sis
       , Bb
       , Fos₀
       , Fos₁
       , has-eq a₁ a₂ a₃ a₄ a₅ is
       , hbs-eq a₁ a₂ a₃ a₄ a₅ is
       , hcs-eq a₁ a₂ a₃ a₄ a₅ is
       , hds-eq a₁ a₂ a₃ a₄ a₅ is
       , trans (abpTransfer-eq b os₀ os₁ is) (transfer-eq a₁ a₂ a₃ a₄ a₅ is)
    where
    a₁ a₂ a₃ a₄ a₅ : D
    a₁ = send · b
    a₂ = ack · b
    a₃ = out · b
    a₄ = corrupt · os₀
    a₅ = corrupt · os₁


Cosmetic changes.

Cosmetic changes.

Ignore-this: d1ac86c67f59bd56c296570dbc89bce5

darcs-hash:20110920064521-3bd4e-9025b902b0445ad3dcd8f94f075ac1242bf906ef.gz

------------------------------------------------------------------------------
-- The map-iterate property: A property using coinduction
------------------------------------------------------------------------------

-- The map-iterate property [1]:
-- map f (iterate f x) = iterate f (f · x)

-- [1] Jeremy Gibbons and Graham Hutton. Proof methods for corecursive
-- programs. Fundamenta Informaticae, XX:1–14, 2005.

module FOTC.Program.MapIterate.MapIterateATP where

open import FOTC.Base

open import FOTC.Data.List
open import FOTC.Data.Stream.Equality

------------------------------------------------------------------------------
-- The map-iterate property.

≈-map-iterate : ∀ f x → map f (iterate f x) ≈ iterate f (f · x)
≈-map-iterate f x = ≈-gfp₂ R helper (x , refl , refl)
  where
  postulate
    unfoldMap : ∀ f y →
                map f (iterate f y) ≡ f · y ∷ map f (iterate f (f · y))
  {-# ATP prove unfoldMap #-}

  postulate
    unfoldIterate : ∀ f y →
                    iterate f (f · y) ≡ f · y ∷ iterate f (f · (f · y))
  {-# ATP prove unfoldIterate #-}

  -- The relation R was based on the relation used by Eduardo Giménez
  -- and Pierre Castéran. A Tutorial on [Co-]Inductive Types in
  -- Coq. May 1998 -- August 17, 2007.
  R : D → D → Set
  R xs ys = ∃ λ y → xs ≡ map f (iterate f y) ∧ ys ≡ iterate f (f · y)

  helper : ∀ {xs ys} → R xs ys → ∃ λ x' → ∃ λ xs' → ∃ λ ys' →
           R xs' ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
  helper {xs} {ys} h = f · y
                     , map f (iterate f (f · y))
                     , iterate f (f · (f · y))
                     , ((f · y) , refl , refl)
                     , trans xs≡map (unfoldMap f y)
                     , trans ys≡iterate (unfoldIterate f y)
    where
    y : D
    y = ∃-proj₁ h

    xs≡map : xs ≡ map f (iterate f y)
    xs≡map = ∧-proj₁ (∃-proj₂ h)

    ys≡iterate : ys ≡ iterate f (f · y)
    ys≡iterate = ∧-proj₂ (∃-proj₂ h)

------------------------------------------------------------------------------
-- The map-iterate property: A property using coinduction
------------------------------------------------------------------------------

-- The map-iterate property [1]:
-- map f (iterate f x) = iterate f (f · x)

-- [1] Jeremy Gibbons and Graham Hutton. Proof methods for corecursive
-- programs. Fundamenta Informaticae, XX:1–14, 2005.

module FOTC.Program.MapIterate.MapIterateATP where

open import FOTC.Base

open import FOTC.Data.List
open import FOTC.Data.Stream.Equality

------------------------------------------------------------------------------
-- The map-iterate property.

≈-map-iterate : (f x : D) → map f (iterate f x) ≈ iterate f (f · x)
≈-map-iterate f x = ≈-gfp₂ R (λ {xs} {ys} → helper xs ys) (x , refl , refl)
  where
  postulate
    unfoldMap : ∀ f y →
                map f (iterate f y) ≡ f · y ∷ map f (iterate f (f · y))
  {-# ATP prove unfoldMap #-}

  postulate
    unfoldIterate : ∀ f y →
                    iterate f (f · y) ≡ f · y ∷ iterate f (f · (f · y))
  {-# ATP prove unfoldIterate #-}

  -- The relation R was based on the relation used by Eduardo Giménez
  -- and Pierre Castéran. A Tutorial on [Co-]Inductive Types in
  -- Coq. May 1998 -- August 17, 2007.
  R : D → D → Set
  R xs ys = ∃ (λ y → xs ≡ map f (iterate f y) ∧ ys ≡ iterate f (f · y))

  helper : ∀ xs ys → R xs ys → ∃ λ x' → ∃ λ xs' → ∃ λ ys' →
             R xs' ys' ∧
             xs ≡ x' ∷ xs' ∧
             ys ≡ x' ∷ ys'
  helper xs ys h = f · y
                   , map f (iterate f (f · y))
                   , iterate f (f · (f · y))
                   , ((f · y) , refl , refl)
                   , trans xs≡map (unfoldMap f y)
                   , trans ys≡iterate (unfoldIterate f y)
    where
    y : D
    y = ∃-proj₁ h

    xs≡map : xs ≡ map f (iterate f y)
    xs≡map = ∧-proj₁ (∃-proj₂ h)

    ys≡iterate : ys ≡ iterate f (f · y)
    ys≡iterate = ∧-proj₂ (∃-proj₂ h)