{-# OPTIONS --without-K #-}
-- https://upload.wikimedia.org/wikipedia/commons/e/e2/SHA-1.svg
-- http://www.faqs.org/rfcs/rfc3174.html
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 Data.Product
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 sha1 where

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

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

    Word : T
    Word = `Bits 32

    map²ʷ : (`𝟚 `× `𝟚 `→ `𝟚) → Word `× Word `→ Word
    map²ʷ = zipWith

    mapʷ : (`𝟚 `→ `𝟚) → Word `→ Word
    mapʷ = map

    lift : ∀ {Γ A B} → (A `→ B) → Γ `→ A → Γ `→ B
    lift f g = g ⁏ f

    lift₂ : ∀ {Γ A B C} → (A `× B `→ C) → Γ `→ A → Γ `→ B → Γ `→ C
    lift₂ op₂ f₀ f₁ = < f₀ , f₁ > ⁏ op₂

    `not : ∀ {Γ} (f : Γ `→ Word) → Γ `→ Word
    `not = lift (mapʷ not)

    infixr 3 _`⊕_
    _`⊕_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
    _`⊕_ = lift₂ (map²ʷ <xor>)

    infixr 3 _`∧_
    _`∧_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
    _`∧_ = lift₂ (map²ʷ <and>)

    infixr 2 _`∨_
    _`∨_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
    _`∨_ = lift₂ (map²ʷ <or>)

    open import Solver.Linear

    module LinSolver = Syntaxᶠ linRewiring

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

    iter : ∀ {n A B C D} → (D `× A `× B `→ D `× C) → D `× `Vec A n `× `Vec B n `→ `Vec C n
    iter {zero}  F = <[]>
    iter {suc n} F = < id × < uncons × uncons > >
                   ⁏ (helper ⁏ < F × id > ⁏ < swap × id > ⁏ assoc ⁏ < id × iter F >)
                   ⁏ <∷>

      where
        open LinSolver
        helper = λ {A} {B} {D} {VA} {VB} →
          rewireᶠ (A ∷ B ∷ D ∷ VA ∷ VB ∷ [])
                  (λ a b d va vb → (d , (a , va) , (b , vb)) ↦ (d , a , b) , (va , vb))

    <⊞> adder : Word `× Word `→ Word
    adder = <tt⁏ <0₂> , id > ⁏ iter full-adder
    <⊞> = adder

    infixl 4 _`⊞_
    _`⊞_ : ∀ {A} (f g : A `→ Word) → A `→ Word
    _`⊞_ = lift₂ <⊞>

    <_,_,_> : ∀ {Γ A B C} → Γ `→ A → Γ `→ B → Γ `→ C → Γ `→ (A `× B `× C)
    < f₀ , f₁ , f₂ > = < f₀ , < f₁ , f₂ > >

    <_,_,_,_,_> : ∀ {Γ A B C D E} → Γ `→ A → Γ `→ B → Γ `→ C
                                  → Γ `→ D → Γ `→ E
                                  → Γ `→ (A `× B `× C `× D `× E)
    < f₀ , f₁ , f₂ , f₃ , f₄ > = < f₀ , < f₁ , < f₂ , f₃ , f₄ > > >

    <<<₅ : `Endo Word
    <<<₅ = rot-left 5

    <<<₃₀ : `Endo Word
    <<<₃₀ = rot-left 30

    Word² = Word `× Word
    Word³ = Word `× Word²
    Word⁴ = Word `× Word³
    Word⁵ = Word `× Word⁴

    open import Data.Digit

    bits : ∀ ℓ → ℕ → `𝟙 `→ `Bits ℓ
    bits ℓ n₀ =  constBits (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₂

            {-
    [_-_mod_] : ℕ → ℕ → ℕ → ℕ
    [ m - n mod p ] = {!!}

    [_+_mod_] : ℕ → ℕ → ℕ → ℕ
    [ m + n mod p ] = {!!}
    -}

    #ʷ = bits 32

    <⊞⁵> : Word⁵ `× Word⁵ `→ Word⁵
    <⊞⁵> = < <⊞> `zip` < <⊞> `zip` < <⊞> `zip` < <⊞> `zip` <⊞> > > > >

    iterateⁿ : ∀ {A} n → (Fin n → `Endo A) → `Endo A
    iterateⁿ zero    f = id
    iterateⁿ (suc n) f = f zero ⁏ iterateⁿ n (f ∘ suc)

    _²⁰ : ∀ {A} → (Fin 20 → `Endo A) → `Endo A
    _²⁰ = iterateⁿ 20

    module _ where

      K₀ = #ʷ 0x5A827999
      K₂ = #ʷ 0x6ED9EBA1
      K₄ = #ʷ 0x8F1BBCDC
      K₆ = #ʷ 0xCA62C1D6

      H0 = #ʷ 0x67452301
      H1 = #ʷ 0xEFCDAB89
      H2 = #ʷ 0x98BADCFE
      H3 = #ʷ 0x10325476
      H4 = #ʷ 0xC3D2E1F0

      A B C D E : Word⁵ `→ Word
      A = fst
      B = snd ⁏ fst
      C = snd ⁏ snd ⁏ fst
      D = snd ⁏ snd ⁏ snd ⁏ fst
      E = snd ⁏ snd ⁏ snd ⁏ snd

      F₀ = B `∧ C `∨ `not B `∧ D
      F₂ = B `⊕ C `⊕ D
      F₄ = B `∧ C `∨ B `∧ D `∨ C `∧ D
      F₆ = F₂

      module _ (F : Word⁵ `→ Word)
               (K : `𝟙  `→ Word)
               (W : `𝟙  `→ Word) where
        Iteration = < A' , A , (B ⁏ <<<₃₀) , C , D >
          where A' = F `⊞ E `⊞ (A ⁏ <<<₅) `⊞ (tt ⁏ W) `⊞ (tt ⁏ K)

      module _ (W : Fin 80 → `𝟙 `→ Word) where
        W₀ W₂ W₄ W₆ : Fin 20 → `𝟙 `→ Word
        W₀ = W ∘ inject+ 60 ∘ raise  0
        W₂ = W ∘ inject+ 40 ∘ raise 20
        W₄ = W ∘ inject+ 20 ∘ raise 40
        W₆ = W ∘ inject+  0 ∘ raise 60

        Iteration⁸⁰ : `Endo Word⁵
        Iteration⁸⁰ =
          (Iteration F₀ K₀ ∘ W₀)²⁰ ⁏
          (Iteration F₂ K₂ ∘ W₂)²⁰ ⁏
          (Iteration F₄ K₄ ∘ W₄)²⁰ ⁏
          (Iteration F₆ K₆ ∘ W₆)²⁰

        pad0s : ℕ → ℕ
        pad0s zero = 512 ∸ 65
        pad0s (suc _) = STUCK where postulate STUCK : ℕ
        -- pad0s n = [ 512 - [ n + 65 mod 512 ] mod 512 ]

        paddedLength : ℕ → ℕ
        paddedLength n = n + (1 + pad0s n + 64)

        padding : ∀ {n} → `Bits n `→ `Bits (paddedLength n)
        padding {n} = < id ,tt⁏ <1∷ < <0ⁿ> {pad0s n} ++ bits 64 n > > > ⁏ append

        ite : Endo (`Endo Word⁵)
        ite f = dup ⁏ first f ⁏ <⊞⁵>

        hash-block : `Endo Word⁵
        hash-block = ite Iteration⁸⁰

      ite' : ∀ n (W : Fin n → Fin 80 → `𝟙 `→ Word)
             → ((Fin 80 → `𝟙 `→ Word) → `Endo Word⁵) → `Endo Word⁵
      ite' zero    W f = id
      ite' (suc n) W f = f (W zero) ⁏ ite' n (W ∘ suc) f

      SHA1 : ∀ n (W : Fin n → Fin 80 → `𝟙 `→ Word) → `𝟙 `→ Word⁵
      SHA1 n W = < H0 , H1 , H2 , H3 , H4 >
               ⁏ ite' n W hash-block

      SHA1-on-0s : `𝟙 `→ Word⁵
      SHA1-on-0s = SHA1 1 (λ _ _ → <0ⁿ>)

module AgdaSHA1 where
  open import FunUniverse.Agda
  open FunSHA1 agdaFunOps
  open import Data.Two

open import IO
import IO.Primitive
open import Data.One
open import Data.Two
open import Data.Product
open import Coinduction
putBit : 𝟚 → IO 𝟙
putBit 1₂ = putStr "1"
putBit 0₂ = putStr "0"
putBits : ∀ {n} → Vec 𝟚 n → IO 𝟙
putBits [] = return _
putBits (x ∷ bs) = ♯ putBit x >> ♯ putBits bs
put× : ∀ {A B : Set} → (A → IO 𝟙) → (B → IO 𝟙) → (A × B) → IO 𝟙
put× pA pB (x , y) = ♯ pA x >> ♯ pB y
{-
main : IO.Primitive.IO 𝟙
main = IO.run (put× putBits (put× putBits (put× putBits (put× putBits
          putBits))) AgdaSHA1.SHA1-on-0s)
-}
firstBit : ∀ {A : Set} → (V.Vec 𝟚 32 × A) → 𝟚
firstBit ((b ∷ _) , _) = b
import FunUniverse.Cost as Cost
open import Data.Nat.Show
sha1-cost : ℕ
sha1-cost = FunSHA1.SHA1-on-0s Cost.timeOps
main : IO.Primitive.IO 𝟙
--main = IO.run (putBit (firstBit (AgdaSHA1.SHA1-on-0s _)))
main = IO.run (putStrLn (show sha1-cost))

-- -}

{-# OPTIONS --without-K #-}
-- https://upload.wikimedia.org/wikipedia/commons/e/e2/SHA-1.svg
-- http://www.faqs.org/rfcs/rfc3174.html
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _∸_)
import Data.Vec as V
open V using (Vec; []; _∷_)
open import Function.NP using (Endo; _∘_)
open import FunUniverse.Core hiding (_,_)
open import Data.Fin using (Fin; zero; suc; #_; inject+; raise) renaming (toℕ to Fin▹ℕ)

open import Solver.Linear

module sha1 where

module FunSHA1
  {t}
  {T : Set t}
  {funU : FunUniverse T}
  (funOps : FunOps funU)
  where

    open FunUniverse funU
    open FunOps funOps renaming (_∘_ to _`∘_)
    module LinSolver = Syntaxᶠ linRewiring

    Word : T
    Word = `Bits 32

    map²ʷ : (`𝟚 `× `𝟚 `→ `𝟚) → Word `× Word `→ Word
    map²ʷ = zipWith

    mapʷ : (`𝟚 `→ `𝟚) → Word `→ Word
    mapʷ = map

    lift : ∀ {Γ A B} → (A `→ B) → Γ `→ A → Γ `→ B
    lift f g = g ⁏ f

    lift₂ : ∀ {Γ A B C} → (A `× B `→ C) → Γ `→ A → Γ `→ B → Γ `→ C
    lift₂ op₂ f₀ f₁ = < f₀ , f₁ > ⁏ op₂

    `not : ∀ {Γ} (f : Γ `→ Word) → Γ `→ Word
    `not = lift (mapʷ not)

    infixr 3 _`⊕_
    _`⊕_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
    _`⊕_ = lift₂ (map²ʷ <xor>)

    infixr 3 _`∧_
    _`∧_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
    _`∧_ = lift₂ (map²ʷ <and>)

    infixr 2 _`∨_
    _`∨_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
    _`∨_ = lift₂ (map²ʷ <or>)

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

    iter : ∀ {n A B C D} → (D `× A `× B `→ D `× C) → D `× `Vec A n `× `Vec B n `→ `Vec C n
    iter {zero}  F = <[]>
    iter {suc n} F = < id × < uncons × uncons > >
                   ⁏ (helper ⁏ < F × id > ⁏ < swap × id > ⁏ assoc ⁏ < id × iter F >)
                   ⁏ <∷>

      where
        open LinSolver
        helper = λ {A} {B} {D} {VA} {VB} →
          rewireᶠ (A ∷ B ∷ D ∷ VA ∷ VB ∷ [])
                  (λ a b d va vb → (d , (a , va) , (b , vb)) ↦ (d , a , b) , (va , vb))

    <⊞> adder : Word `× Word `→ Word
    adder = <tt⁏ <0₂> , id > ⁏ iter full-adder
    <⊞> = adder

    infixl 4 _`⊞_
    _`⊞_ : ∀ {A} (f g : A `→ Word) → A `→ Word
    _`⊞_ = lift₂ <⊞>

    <_,_,_> : ∀ {Γ A B C} → Γ `→ A → Γ `→ B → Γ `→ C → Γ `→ (A `× B `× C)
    < f₀ , f₁ , f₂ > = < f₀ , < f₁ , f₂ > >

    <_,_,_,_,_> : ∀ {Γ A B C D E} → Γ `→ A → Γ `→ B → Γ `→ C
                                  → Γ `→ D → Γ `→ E
                                  → Γ `→ (A `× B `× C `× D `× E)
    < f₀ , f₁ , f₂ , f₃ , f₄ > = < f₀ , < f₁ , < f₂ , f₃ , f₄ > > >

    <<<₅ : `Endo Word
    <<<₅ = rot-left 5

    <<<₃₀ : `Endo Word
    <<<₃₀ = rot-left 30

    Word² = Word `× Word
    Word³ = Word `× Word²
    Word⁴ = Word `× Word³
    Word⁵ = Word `× Word⁴

    open import Data.Digit

    bits : ∀ ℓ → ℕ → `𝟙 `→ `Bits ℓ
    bits ℓ n₀ =  constBits (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₂

            {-
    [_-_mod_] : ℕ → ℕ → ℕ → ℕ
    [ m - n mod p ] = {!!}

    [_+_mod_] : ℕ → ℕ → ℕ → ℕ
    [ m + n mod p ] = {!!}
    -}

    #ʷ = bits 32

    <⊞⁵> : Word⁵ `× Word⁵ `→ Word⁵
    <⊞⁵> = < <⊞> `zip` < <⊞> `zip` < <⊞> `zip` < <⊞> `zip` <⊞> > > > >

    iterateⁿ : ∀ {A} n → (Fin n → `Endo A) → `Endo A
    iterateⁿ zero    f = id
    iterateⁿ (suc n) f = f zero ⁏ iterateⁿ n (f ∘ suc)

    _²⁰ : ∀ {A} → (Fin 20 → `Endo A) → `Endo A
    _²⁰ = iterateⁿ 20

    module _ where

      K₀ = #ʷ 0x5A827999
      K₂ = #ʷ 0x6ED9EBA1
      K₄ = #ʷ 0x8F1BBCDC
      K₆ = #ʷ 0xCA62C1D6

      H0 = #ʷ 0x67452301
      H1 = #ʷ 0xEFCDAB89
      H2 = #ʷ 0x98BADCFE
      H3 = #ʷ 0x10325476
      H4 = #ʷ 0xC3D2E1F0

      A B C D E : Word⁵ `→ Word
      A = fst
      B = snd ⁏ fst
      C = snd ⁏ snd ⁏ fst
      D = snd ⁏ snd ⁏ snd ⁏ fst
      E = snd ⁏ snd ⁏ snd ⁏ snd

      F₀ = B `∧ C `∨ `not B `∧ D
      F₂ = B `⊕ C `⊕ D
      F₄ = B `∧ C `∨ B `∧ D `∨ C `∧ D
      F₆ = F₂

      module _ (F : Word⁵ `→ Word)
               (K : `𝟙  `→ Word)
               (W : `𝟙  `→ Word) where
        Iteration = < A' , A , (B ⁏ <<<₃₀) , C , D >
          where A' = F `⊞ E `⊞ (A ⁏ <<<₅) `⊞ (tt ⁏ W) `⊞ (tt ⁏ K)

      module _ (W : Fin 80 → `𝟙 `→ Word) where
        W₀ W₂ W₄ W₆ : Fin 20 → `𝟙 `→ Word
        W₀ = W ∘ inject+ 60 ∘ raise  0
        W₂ = W ∘ inject+ 40 ∘ raise 20
        W₄ = W ∘ inject+ 20 ∘ raise 40
        W₆ = W ∘ inject+  0 ∘ raise 60

        Iteration⁸⁰ : `Endo Word⁵
        Iteration⁸⁰ =
          (Iteration F₀ K₀ ∘ W₀)²⁰ ⁏
          (Iteration F₂ K₂ ∘ W₂)²⁰ ⁏
          (Iteration F₄ K₄ ∘ W₄)²⁰ ⁏
          (Iteration F₆ K₆ ∘ W₆)²⁰

        pad0s : ℕ → ℕ
        pad0s zero = 512 ∸ 65
        pad0s (suc _) = STUCK where postulate STUCK : ℕ
        -- pad0s n = [ 512 - [ n + 65 mod 512 ] mod 512 ]

        paddedLength : ℕ → ℕ
        paddedLength n = n + (1 + pad0s n + 64)

        padding : ∀ {n} → `Bits n `→ `Bits (paddedLength n)
        padding {n} = < id ,tt⁏ <1∷ < <0ⁿ> {pad0s n} ++ bits 64 n > > > ⁏ append

        ite : Endo (`Endo Word⁵)
        ite f = dup ⁏ first f ⁏ <⊞⁵>

        hash-block : `Endo Word⁵
        hash-block = ite Iteration⁸⁰

      ite' : ∀ n (W : Fin n → Fin 80 → `𝟙 `→ Word)
             → ((Fin 80 → `𝟙 `→ Word) → `Endo Word⁵) → `Endo Word⁵
      ite' zero    W f = id
      ite' (suc n) W f = f (W zero) ⁏ ite' n (W ∘ suc) f

      SHA1 : ∀ n (W : Fin n → Fin 80 → `𝟙 `→ Word) → `𝟙 `→ Word⁵
      SHA1 n W = < H0 , H1 , H2 , H3 , H4 >
               ⁏ ite' n W hash-block

      SHA1-on-0s : `𝟙 `→ Word⁵
      SHA1-on-0s = SHA1 1 (λ _ _ → <0ⁿ>)

module AgdaSHA1 where
  open import FunUniverse.Agda
  open FunSHA1 agdaFunOps
  open import Data.Two

open import IO
import IO.Primitive
open import Data.One
open import Data.Two
open import Data.Product
open import Coinduction
putBit : 𝟚 → IO 𝟙
putBit 1₂ = putStr "1"
putBit 0₂ = putStr "0"
putBits : ∀ {n} → Vec 𝟚 n → IO 𝟙
putBits [] = return _
putBits (x ∷ bs) = ♯ putBit x >> ♯ putBits bs
put× : ∀ {A B : Set} → (A → IO 𝟙) → (B → IO 𝟙) → (A × B) → IO 𝟙
put× pA pB (x , y) = ♯ pA x >> ♯ pB y
{-
main : IO.Primitive.IO 𝟙
main = IO.run (put× putBits (put× putBits (put× putBits (put× putBits
          putBits))) AgdaSHA1.SHA1-on-0s)
-}
firstBit : ∀ {A : Set} → (V.Vec 𝟚 32 × A) → 𝟚
firstBit ((b ∷ _) , _) = b
import FunUniverse.Cost as Cost
open import Data.Nat.Show
sha1-cost : ℕ
sha1-cost = FunSHA1.SHA1-on-0s Cost.timeOps
main : IO.Primitive.IO 𝟙
--main = IO.run (putBit (firstBit (AgdaSHA1.SHA1-on-0s _)))
main = IO.run (putStrLn (show sha1-cost))

-- -}

Fix sha1...

Fix sha1...


{-# OPTIONS --without-K #-}
open import Type hiding (★)

module Data.Tree.Binary where

data BinTree {a} (A : ★ a) : ★ a where
  empty : BinTree A
  leaf  : A → BinTree A
  fork  : (ℓ r : BinTree A) → BinTree A

{-# OPTIONS --without-K #-}
open import Type hiding (★)

open import Level
open import Data.Zero
open import Data.Sum

module Data.Tree.Binary where

data BinTree {a} (A : ★ a) : ★ a where
  empty : BinTree A
  leaf  : A → BinTree A
  fork  : (ℓ r : BinTree A) → BinTree A

Any : ∀ {a p}{A : ★ a}(P : A → ★ p) → BinTree A → ★ p
Any P empty = Lift 𝟘
Any P (leaf x) = P x
Any P (fork ts ts₁) = Any P ts ⊎ Any P ts₁

Add Any predicate for binary tree

Add Any predicate for binary tree


{-# OPTIONS --without-K #-}
open import Type.Eq
open import FFI.JS using (Bool; trace-call; _++_)
open import FFI.JS.Check
  renaming (check      to check?)
--renaming (warn-check to check?)

open import FFI.JS.BigI
open import Data.List.Base using (List; foldr)
open import Data.Two hiding (_==_)
open import Relation.Binary.PropositionalEquality
open import Algebra.Raw
open import Algebra.Group

-- TODO carry on a primality proof of p
module Crypto.JS.BigI.CyclicGroup (p : BigI) where

abstract
  ℤ[_]★ : Set
  ℤ[_]★ = BigI

  private
    ℤp★ : Set
    ℤp★ = BigI

    mod-p : BigI → ℤp★
    mod-p x = mod x p

  -- There are two ways to go from BigI to ℤp★: check and mod-p
  -- Use check for untrusted input data and mod-p for internal
  -- computation.
  BigI▹ℤ[_]★ : BigI → ℤp★
  BigI▹ℤ[_]★ = -- trace-call "BigI▹ℤ[_]★ "
    λ x →
      (check? (x <I p)
         (λ _ → "Not below the modulus: p:" ++ toString p ++ " is less than x:" ++ toString x)
         (check? (x >I 0I)
            (λ _ → "Should be strictly positive: " ++ toString x ++ " <= 0") x))

  check-non-zero : ℤp★ → BigI
  check-non-zero = -- trace-call "check-non-zero "
    λ x → check? (x >I 0I) (λ _ → "Should be non zero") x

  repr : ℤp★ → BigI
  repr x = x

  1# : ℤp★
  1# = 1I

  1/_ : ℤp★ → ℤp★
  1/ x = modInv (check-non-zero x) p

  _^_ : ℤp★ → BigI → ℤp★
  x ^ y = modPow x y p

_*_ _/_ : ℤp★ → ℤp★ → ℤp★

x * y = mod-p (multiply (repr x) (repr y))
x / y = x * 1/ y

instance
  ℤ[_]★-Eq? : Eq? ℤp★
  ℤ[_]★-Eq? = record
    { _==_ = _=='_
    ; ≡⇒== = ≡⇒=='
    ; ==⇒≡ = ==⇒≡' }
    where
      _=='_ : ℤp★ → ℤp★ → 𝟚
      x ==' y = equals (repr x) (repr y)
      postulate
        ≡⇒==' : ∀ {x y} → x ≡ y → ✓ (x ==' y)
        ==⇒≡' : ∀ {x y} → ✓ (x ==' y) → x ≡ y

prod : List ℤp★ → ℤp★
prod = foldr _*_ 1#

mon-ops : Monoid-Ops ℤp★
mon-ops = _*_ , 1#

grp-ops : Group-Ops ℤp★
grp-ops = mon-ops , 1/_

postulate
  grp-struct : Group-Struct grp-ops

grp : Group ℤp★
grp = grp-ops , grp-struct

module grp = Group grp
-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Type.Eq
open import FFI.JS using (Bool; trace-call; _++_)
open import FFI.JS.Check
  renaming (check      to check?)
--renaming (warn-check to check?)

open import FFI.JS.BigI
open import Data.List.Base using (List; foldr)
open import Data.Two hiding (_==_)
open import Relation.Binary.PropositionalEquality
open import Algebra.Raw
open import Algebra.Group

-- TODO carry on a primality proof of p
module Crypto.JS.BigI.CyclicGroup (p : BigI) where

abstract
  ℤ[_]★ : Set
  ℤ[_]★ = BigI

  private
    ℤp★ : Set
    ℤp★ = BigI

    mod-p : BigI → ℤp★
    mod-p x = mod x p

  -- There are two ways to go from BigI to ℤp★: check and mod-p
  -- Use check for untrusted input data and mod-p for internal
  -- computation.
  BigI▹ℤ[_]★ : BigI → ℤp★
  BigI▹ℤ[_]★ = -- trace-call "BigI▹ℤ[_]★ "
    λ x →
      (check? (x <I p)
         (λ _ → "Not below the modulus: p:" ++ toString p ++ " is less than x:" ++ toString x)
         (check? (x >I 0I)
            (λ _ → "Should be strictly positive: " ++ toString x ++ " <= 0") x))

  repr : ℤp★ → BigI
  repr x = x

  1# : ℤp★
  1# = 1I

  1/_ : ℤp★ → ℤp★
  1/ x = modInv x p

  _^_ : ℤp★ → BigI → ℤp★
  x ^ y = modPow x y p

_*_ _/_ : ℤp★ → ℤp★ → ℤp★

x * y = mod-p (multiply (repr x) (repr y))
x / y = x * 1/ y

instance
  ℤ[_]★-Eq? : Eq? ℤp★
  ℤ[_]★-Eq? = record
    { _==_ = _=='_
    ; ≡⇒== = ≡⇒=='
    ; ==⇒≡ = ==⇒≡' }
    where
      _=='_ : ℤp★ → ℤp★ → 𝟚
      x ==' y = equals (repr x) (repr y)
      postulate
        ≡⇒==' : ∀ {x y} → x ≡ y → ✓ (x ==' y)
        ==⇒≡' : ∀ {x y} → ✓ (x ==' y) → x ≡ y

prod : List ℤp★ → ℤp★
prod = foldr _*_ 1#

mon-ops : Monoid-Ops ℤp★
mon-ops = _*_ , 1#

grp-ops : Group-Ops ℤp★
grp-ops = mon-ops , 1/_

postulate
  grp-struct : Group-Struct grp-ops

grp : Group ℤp★
grp = grp-ops , grp-struct

module grp = Group grp
-- -}
-- -}
-- -}
-- -}
-- -}

Remove a useless check: the point of ℤp★ is to not have 0


{-# OPTIONS --copatterns #-}
-- Compression can be used an an Oracle to defeat encryption.
-- Here we show how compressing before encrypting lead to a
-- NOT semantically secure construction (IND-CPA).
module Attack.Compression where

open import Type using (★)
open import Function
open import Data.Nat.NP
open import Data.Two renaming (_==_ to _==ᵇ_)
open import Data.Product
open import Data.Zero
open import Relation.Binary.PropositionalEquality.NP

import Game.IND-CPA

record Sized (A : ★) : ★ where
  field
    size  : A → ℕ

open Sized {{...}}

module _ {A B} {{_ : Sized A}} {{_ : Sized B}} where
    -- Same size
    _==ˢ_ : A → B → 𝟚
    x ==ˢ y = size x == size y

    -- Same size
    _≡ˢ_ : A → B → ★
    x ≡ˢ y = size x ≡ size y

    ≡ˢ→==ˢ : ∀ {x y} → x ≡ˢ y → (x ==ˢ y) ≡ 1₂
    ≡ˢ→==ˢ {x} {y} x≡ˢy rewrite x≡ˢy = ✓→≡ (==.refl {size y})

    ==ˢ→≡ˢ : ∀ {x y} → (x ==ˢ y) ≡ 1₂ → x ≡ˢ y
    ==ˢ→≡ˢ p = ==.sound _ _ (≡→✓ p)

module _ {PubKey Message CipherText Rₑ : ★}
         (Enc  : PubKey → Message → Rₑ → CipherText)
         {{_ : Sized Message}}
         {{_ : Sized CipherText}}
  where
    -- Encryption size is independant of the randomness
    EncSizeRndInd =
      ∀ {pk m r₀ r₁} → Enc pk m r₀ ≡ˢ Enc pk m r₁

    -- Encrypted ciphertexts of the same size, will lead to messages of the same size
    EncLeakSize =
      ∀ {pk m₀ m₁ r₀ r₁} → Enc pk m₀ r₀ ≡ˢ Enc pk m₁ r₁ → m₀ ≡ˢ m₁

module M
  {Message CompressedMessage : ★}
  {{_ : Sized CompressedMessage}}

  (compress : Message → CompressedMessage)

  -- 2 messages which have different size after compression
  (m₀ m₁ : Message)
  (different-compression
     : size (compress m₀) ≢ size (compress m₁))

  (PubKey     : ★)
  (SecKey     : ★)
  (CipherText : ★)
  {{_ : Sized CipherText}}
  (Rₑ Rₖ Rₓ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc : PubKey → CompressedMessage → Rₑ → CipherText)
  (EncSizeRndInd : EncSizeRndInd Enc)
  (EncLeakSize : EncLeakSize Enc)
  where

  -- Our adversary runs one encryption
  Rₐ = Rₑ

  CEnc : PubKey → Message → Rₑ → CipherText
  CEnc pk m rₑ = Enc pk (compress m) rₑ

  module IND-CPA = Game.IND-CPA PubKey SecKey Message CipherText
                                Rₑ Rₖ Rₐ Rₓ KeyGen CEnc
  open IND-CPA.Adversary

  A : IND-CPA.Adversary
  m  A = λ _ _ → [0: m₀ 1: m₁ ]
  b′ A = λ rₑ pk c → c ==ˢ CEnc pk m₁ rₑ

  -- The adversary A is always winning.
  A-always-wins : ∀ b r → IND-CPA.EXP b A r ≡ b
  A-always-wins 0₂ _ = ≢1→≡0 (different-compression ∘ EncLeakSize ∘ ==ˢ→≡ˢ)
  A-always-wins 1₂ _ = ≡ˢ→==ˢ EncSizeRndInd

  lem : ∀ x y → (x ==ᵇ y) ≡ 0₂ → not (x ==ᵇ y) ≡ 1₂
  lem 1₂ 1₂ = λ ()
  lem 1₂ 0₂ = λ _ → refl
  lem 0₂ 1₂ = λ _ → refl
  lem 0₂ 0₂ = λ ()

  {-
  A-always-wins' : ∀ r → IND-CPA.game A r ≡ 1₂
  A-always-wins' (0₂ , r) = {!lem (not (IND-CPA.EXP 0₂ {!A!} r)) (IND-CPA.EXP 1₂ A r) (A-always-wins 0₂ r)!}
  A-always-wins' (1₂ , r) = A-always-wins 1₂ r
  -}

{-# OPTIONS --copatterns #-}
-- Compression can be used an an Oracle to defeat encryption.
-- Here we show how compressing before encrypting lead to a
-- NOT semantically secure construction (IND-CPA).
module Attack.Compression where

open import Type using (★)
open import Function.NP
open import Data.Nat.NP
open import Data.Two renaming (_==_ to _==ᵇ_)
open import Data.Product
open import Data.Zero
open import Relation.Binary.PropositionalEquality.NP

import Game.IND-CPA

record Sized (A : ★) : ★ where
  field
    size  : A → ℕ

open Sized {{...}}

module EqSized {A B : ★} {{_ : Sized A}} {{_ : Sized B}} where
    -- Same size
    _==ˢ_ : A → B → 𝟚
    x ==ˢ y = size x == size y

    -- Same size
    _≡ˢ_ : A → B → ★
    x ≡ˢ y = size x ≡ size y

    ≡ˢ→==ˢ : ∀ {x y} → x ≡ˢ y → (x ==ˢ y) ≡ 1₂
    ≡ˢ→==ˢ {x} {y} x≡ˢy rewrite x≡ˢy = ✓→≡ (==.refl {size y})

    ==ˢ→≡ˢ : ∀ {x y} → (x ==ˢ y) ≡ 1₂ → x ≡ˢ y
    ==ˢ→≡ˢ p = ==.sound _ _ (≡→✓ p)

module EncSized
         {PubKey Message CipherText Rₑ : ★}
         (enc  : PubKey → Message → Rₑ → CipherText)
         {{_ : Sized Message}}
         {{_ : Sized CipherText}}
  where
    open EqSized

    -- Encryption size is independant of the randomness
    EncSizeRndInd =
      ∀ {pk m r₀ r₁} → enc pk m r₀ ≡ˢ enc pk m r₁

    -- Encrypted ciphertexts of the same size, will lead to messages of the same size
    EncLeakSize =
      ∀ {pk m₀ m₁ r₀ r₁} → enc pk m₀ r₀ ≡ˢ enc pk m₁ r₁ → m₀ ≡ˢ m₁

module M
  {Message CompressedMessage : ★}
  {{_ : Sized CompressedMessage}}

  (compress : Message → CompressedMessage)

  -- 2 messages which have different size after compression
  (m₀ m₁ : Message)
  (different-compression
     : size (compress m₀) ≢ size (compress m₁))

  (PubKey     : ★)
  (SecKey     : ★)
  (CipherText : ★)
  {{_ : Sized CipherText}}
  (Rₑ Rₖ Rₓ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (enc : PubKey → CompressedMessage → Rₑ → CipherText)
  (open EncSized enc)
  (encSizeRndInd : EncSizeRndInd)
  (encLeakSize : EncLeakSize)
  where

  -- Our adversary runs one encryption
  Rₐ = Rₑ

  CEnc : PubKey → Message → Rₑ → CipherText
  CEnc pk m rₑ = enc pk (compress m) rₑ

  module IND-CPA = Game.IND-CPA PubKey SecKey Message CipherText
                                Rₑ Rₖ Rₐ Rₓ KeyGen CEnc
  open IND-CPA.Adversary
  open EqSized {CipherText}{CipherText} {{it}} {{it}}

  A : IND-CPA.Adversary
  m  A = λ _ _ → [0: m₀ 1: m₁ ]
  b′ A = λ rₑ pk c → c ==ˢ CEnc pk m₁ rₑ

  -- The adversary A is always winning.
  A-always-wins : ∀ b r → IND-CPA.EXP b A r ≡ b
  A-always-wins 0₂ _ = ≢1→≡0 (different-compression ∘′ encLeakSize ∘′ ==ˢ→≡ˢ)
  A-always-wins 1₂ _ = ≡ˢ→==ˢ encSizeRndInd

  -- One should be able to derive this one from A-always-wins and the game-flipping general lemma in the exploration lib
  {-
  A-always-wins' : ∀ r → IND-CPA.game A r ≡ 1₂
  A-always-wins' (0₂ , r) = {!lem (not (IND-CPA.EXP 0₂ {!A!} r)) (IND-CPA.EXP 1₂ A r) (A-always-wins 0₂ r)!}
    where
    lem : ∀ x y → (x ==ᵇ y) ≡ 0₂ → not (x ==ᵇ y) ≡ 1₂
    lem 1₂ 1₂ = λ ()
    lem 1₂ 0₂ = λ _ → refl
    lem 0₂ 1₂ = λ _ → refl
    lem 0₂ 0₂ = λ ()
  A-always-wins' (1₂ , r) = A-always-wins 1₂ r
  -}

Attack.Compression: work around the instance argument becoming weaker...


import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value

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

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

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality

open import Base.Change.Algebra as CA using
  ( ChangeAlgebra
  ; ChangeAlgebraFamily
  ; change-algebra₍_₎
  ; family
  ; Δ₍_₎
  )
open import Level

Structure : Set₁
Structure = ChangeAlgebraFamily zero ⟦_⟧Base

module Structure (change-algebra-base : Structure) where
  change-algebra : ∀ τ → ChangeAlgebra zero ⟦ τ ⟧Type
  change-algebra (base ι) = change-algebra₍ ι ₎
  change-algebra (τ₁ ⇒ τ₂) = CA.FunctionChanges.changeAlgebra _ _ {{change-algebra τ₁}} {{change-algebra τ₂}}

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

  ---------------
  -- Interface --
  ---------------

  open CA public
    using
      ( Δ₍_₎
      ; update′
      ; diff′
      ; nil₍_₎
      ; update-diff₍_₎
      ; update-nil₍_₎
      )

  --------------------
  -- Implementation --
  --------------------

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

  open CA public using
    ( before
    ; after
    ; before₍_₎
    ; after₍_₎
    )

  ------------------
  -- Environments --
  ------------------

  open CA.FunctionChanges public using (cons)
  open CA public using () renaming
    ( [] to ∅
    ; _∷_ to _•_
    )

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

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

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value

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

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

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra as CA
  using (ChangeAlgebraFamily)
open import Level

Structure : Set₁
Structure = ChangeAlgebraFamily zero ⟦_⟧Base

module Structure (change-algebra-base : Structure) where
  -- change algebras

  open CA public renaming
    ( [] to ∅
    ; _∷_ to _•_
    )

  -- change algebra for every type

  change-algebra : ∀ τ → ChangeAlgebra zero ⟦ τ ⟧Type
  change-algebra (base ι) = change-algebra₍ ι ₎
  change-algebra (τ₁ ⇒ τ₂) = CA.FunctionChanges.changeAlgebra _ _ {{change-algebra τ₁}} {{change-algebra τ₂}}

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

  -- function changes

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

  -- environment changes

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

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

Simplify reexports.

Simplify reexports.

Merge open declarations, reexport everything.

Old-commit-hash: 69a4b0415ae43f3db65282495914ddf7a6fe06fd


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

open import Type
open import Data.Bit
open import Data.Maybe
open import Data.Product
open import Data.One
open import Control.Strategy renaming (run to runStrategy; map to mapStrategy)

open import Function

open import Relation.Binary.PropositionalEquality

import Game.IND-CPA-dagger
import Game.IND-CPA

module Game.Transformation.CPAd-CPA
  (PubKey    : ★)
  (SecKey    : ★)
  (Message   : ★)
  (CipherText : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)
  (Dec    : SecKey → CipherText → Message)

where

module CPA† = Game.IND-CPA-dagger PubKey SecKey Message CipherText Rₑ Rₖ Rₐ 𝟙 KeyGen Enc
module CPA  = Game.IND-CPA        PubKey SecKey Message CipherText Rₑ Rₖ Rₐ 𝟙 KeyGen Enc

{-
f : (Message × Message) × (CipherText → DecRound Bit)
  → (Message × Message) × (CipherText → CipherText → DecRound Bit)
f (m , g) = m , λ c _ → g c
-}

R-transform : CPA†.R → CPA.R
R-transform (rₐ , rₖ , rₑ , _ , _) = rₐ , rₖ , rₑ , _

module _ (A : CPA.Adversary) where
  open CPA.Adversary

  A† : CPA†.Adversary
  m  A† = m A
  b′ A† rₐ pk c₀ c₁ = b′ A rₐ pk c₀

  lemma : ∀ b t r
          → CPA.EXP  b   A  (R-transform r)
          ≡ CPA†.EXP b t A† r
  lemma _ _ _ = refl

  -- If we are able to do the transformation, then we get the same advantage
  correct : ∀ b r
            → CPA.EXP  b A          (R-transform r)
            ≡ CPA†.EXP b (not b) A† r
  correct _ _ = refl

-- -}

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

open import Type
open import Data.Bit
open import Data.Maybe
open import Data.Product
open import Data.One
open import Control.Strategy renaming (run to runStrategy; map to mapStrategy)

open import Function

open import Relation.Binary.PropositionalEquality

import Game.IND-CPA-dagger
import Game.IND-CPA

module Game.Transformation.CPAd-CPA
  (PubKey    : ★)
  (SecKey    : ★)
  (Message   : ★)
  (CipherText : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)
  (Dec    : SecKey → CipherText → Message)

where

module CPA† = Game.IND-CPA-dagger PubKey SecKey Message CipherText Rₑ Rₖ Rₐ 𝟙 KeyGen Enc
module CPA  = Game.IND-CPA        PubKey SecKey Message CipherText Rₑ Rₖ Rₐ 𝟙 KeyGen Enc

R-transform : CPA†.R → CPA.R
R-transform (rₐ , rₖ , rₑ , _ , _) = rₐ , rₖ , rₑ , _

module _ (A : CPA.Adversary) where
  open CPA†.Adversary
  module A = CPA.Adversary A

  A† : CPA†.Adversary
  m  A† = A.m
  b′ A† rₐ pk c₀ c₁ = A.b′ rₐ pk c₀

  lemma : ∀ b t r
          → CPA.EXP  b   A  (R-transform r)
          ≡ CPA†.EXP b t A† r
  lemma _ _ _ = refl

  -- If we are able to do the transformation, then we get the same advantage
  correct : ∀ b r
            → CPA.EXP  b A          (R-transform r)
            ≡ CPA†.EXP b (not b) A† r
  correct _ _ = refl

-- -}

fix copattern error in CPAd-CPA

fix copattern error in CPAd-CPA


{-# OPTIONS --guardedness-preserving-type-constructors #-}

-- Agda specification of `coerce`
--
-- Incomplete: too much work just to make type system happy.
-- Conversions between morally identical types obscure
-- the operational content.

open import Function
open import Data.Product
open import Data.Maybe
open import Data.Bool hiding (_≟_)
open import Data.Sum
open import Data.Nat
import Data.Fin as Fin
open Fin using (Fin ; zero ; suc)

open import Relation.Nullary using (Dec ; yes ; no)
open import Coinduction renaming (Rec to Fix ; fold to roll ; unfold to unroll)

-- Things fail sometimes
postulate fail : ∀ {ℓ} {A : Set ℓ} → A

-- I know what I'm doing
postulate unsafeCast : ∀ {A B : Set} → A → B

data Data : Set where
  base : ℕ → Data
  pair : Data → Data → Data
  plus : Data → Data → Data
  var  : ℕ → Data
  fix  : Data → Data

-- infinite environments
Env : ∀ {ℓ} → Set ℓ → Set ℓ
Env A = ℕ → A

infixr 0 decide_then_else_

decide_then_else_ : ∀ {p ℓ} {P : Set p} {A : Set ℓ} → Dec P → A → A → A
decide yes p then x else y = x
decide no ¬p then x else y = y

--update : ∀ {ℓ} {A : Set ℓ} → ℕ → A → Env A → Env A
--update n v env = λ m → decide n ≟ m then v else env m

prepend : ∀ {ℓ} {A : Set ℓ} → A → Env A → Env A
prepend v env zero = v
prepend v env (suc m) = env m

-- universe construction; always terminating.
{-# NO_TERMINATION_CHECK #-}
uc : Data → Env Set → Set
uc (base x) ρ = Fin x
uc (pair S T) ρ = uc S ρ × uc T ρ
uc (plus S T) ρ = uc S ρ ⊎ uc T ρ
uc (var x) ρ = ρ x
uc (fix D) ρ = set where set = Fix (♯ (uc D (prepend set ρ)))

∅ : ∀ {ℓ} {A : Set ℓ} → Env A
∅ = fail

my-nat-data : Data
my-nat-data = fix (plus (base 1) (var zero))

My-nat : Set
My-nat = uc my-nat-data ∅

my-zero : My-nat
my-zero = roll (inj₁ zero)

my-one : My-nat
my-one = roll (inj₂ (roll (inj₁ zero)))

-- nonterminating stuff
botData : Data
botData = fix (var zero)

botType : Set
botType = uc botData ∅

{-# NON_TERMINATING #-}
⋯ : botType
⋯ = roll (roll (roll (roll (roll (roll ⋯)))))

shift : ℕ → ℕ → Data → Data
shift c d (base x) = base x
shift c d (pair S T) = pair (shift c d S) (shift c d T)
shift c d (plus S T) = plus (shift c d S) (shift c d T)
shift c d (var k) = decide suc k ≤? c then var k else var (k + d)
shift c d (fix D) = fix (shift c d D)

_[_↦_] : Data → ℕ → Data → Data
base x [ n ↦ S ] = base x
pair T T₁ [ n ↦ S ] = pair (T [ n ↦ S ]) (T₁ [ n ↦ S ])
plus T T₁ [ n ↦ S ] = plus (T [ n ↦ S ]) (T₁ [ n ↦ S ])
var k [ n ↦ S ] = decide k ≟ n then S else var k
fix T [ n ↦ S ] = fix (T [ n + 1 ↦ shift 0 1 S ])

import Level
open import Category.Monad
open RawMonad {Level.zero} monad

{-# NON_TERMINATING #-}
coerce : (S : Data) → (T : Data) → Maybe (uc S ∅ → (uc T ∅))

coerce (base m) (base n) with m ≤? n
... | yes m≤n = just (λ s → Fin.inject≤ s m≤n)
... | no  m>n = nothing

coerce (pair S₁ S₂) (pair T₁ T₂) =
  coerce S₁ T₁ >>= (λ f₁ →
  coerce S₂ T₂ >>= (λ f₂ →
  return (λ s → f₁ (proj₁ s) , f₂ (proj₂ s))))

coerce (plus S₁ S₂) (plus T₁ T₂) =
  coerce S₁ T₁ >>= (λ f₁ →
  coerce S₂ T₂ >>= (λ f₂ →
  return [ inj₁ ∘ f₁ , inj₂ ∘ f₂ ]))

coerce (var j) T =
  nothing -- should not happen

coerce (fix S) T =
  let
    S′ = S [ 0 ↦ fix S ]
  in
    coerce S′ T >>= (λ f →
    return (λ { (roll x) → f (unsafeCast x) }))

coerce S (fix T) =
  let
    T′ = T [ 0 ↦ fix T ]
  in
    coerce S T′ >>= (λ f →
    return (λ x → (roll (unsafeCast (f x)))))

coerce _ _ = nothing

{-# OPTIONS --guardedness-preserving-type-constructors #-}

-- Agda specification of `coerce`
--
-- Incomplete: too much work just to make type system happy.
-- Conversions between morally identical types obscure
-- the operational content.

open import Function
open import Data.Product
open import Data.Maybe
open import Data.Bool hiding (_≟_)
open import Data.Sum
open import Data.Nat
import Data.Fin as Fin
open Fin using (Fin ; zero ; suc)

open import Relation.Nullary using (Dec ; yes ; no)
open import Coinduction renaming (Rec to Fix ; fold to roll ; unfold to unroll)

-- Things fail sometimes
postulate fail : ∀ {ℓ} {A : Set ℓ} → A

-- I know what I'm doing
postulate unsafeCast : ∀ {A B : Set} → A → B

data Data : Set where
  base : ℕ → Data
  pair : Data → Data → Data
  plus : Data → Data → Data
  var  : ℕ → Data
  fix  : Data → Data

-- infinite environments
Env : ∀ {ℓ} → Set ℓ → Set ℓ
Env A = ℕ → A

infixr 0 decide_then_else_

decide_then_else_ : ∀ {p ℓ} {P : Set p} {A : Set ℓ} → Dec P → A → A → A
decide yes p then x else y = x
decide no ¬p then x else y = y

--update : ∀ {ℓ} {A : Set ℓ} → ℕ → A → Env A → Env A
--update n v env = λ m → decide n ≟ m then v else env m

prepend : ∀ {ℓ} {A : Set ℓ} → A → Env A → Env A
prepend v env zero = v
prepend v env (suc m) = env m

-- universe construction; always terminating.
{-# NO_TERMINATION_CHECK #-}
uc : Data → Env Set → Set
uc (base x) ρ = Fin x
uc (pair S T) ρ = uc S ρ × uc T ρ
uc (plus S T) ρ = uc S ρ ⊎ uc T ρ
uc (var x) ρ = ρ x
uc (fix D) ρ = set where set = Fix (♯ (uc D (prepend set ρ)))

∅ : ∀ {ℓ} {A : Set ℓ} → Env A
∅ = fail

my-nat-data : Data
my-nat-data = fix (plus (base 1) (var zero))

My-nat : Set
My-nat = uc my-nat-data ∅

my-zero : My-nat
my-zero = roll (inj₁ zero)

my-one : My-nat
my-one = roll (inj₂ (roll (inj₁ zero)))

-- nonterminating stuff
botData : Data
botData = fix (var zero)

botType : Set
botType = uc botData ∅

{-# NON_TERMINATING #-}
⋯ : botType
⋯ = roll (roll (roll (roll (roll (roll ⋯)))))

shift : ℕ → ℕ → Data → Data
shift c d (base x) = base x
shift c d (pair S T) = pair (shift c d S) (shift c d T)
shift c d (plus S T) = plus (shift c d S) (shift c d T)
shift c d (var k) = decide suc k ≤? c then var k else var (k + d)
shift c d (fix D) = fix (shift c d D)

_[_↦_] : Data → ℕ → Data → Data
base x [ n ↦ S ] = base x
pair T T₁ [ n ↦ S ] = pair (T [ n ↦ S ]) (T₁ [ n ↦ S ])
plus T T₁ [ n ↦ S ] = plus (T [ n ↦ S ]) (T₁ [ n ↦ S ])
var k [ n ↦ S ] = decide k ≟ n then S else var k
fix T [ n ↦ S ] = fix (T [ n + 1 ↦ shift 0 1 S ])

import Level
open import Category.Monad
open RawMonad {Level.zero} monad

-- terminating specification of `coerce`
-- it is terminating because:
--
-- 1. if `fix T` is contractive (i. e., fix T != μX. X),
--    then the `fix T` case will trigger one of the other cases.
--
-- 2. in every other case, the input data `s` is stripped of
--    a constructor.
--
-- This `coerce` is an interpreter.
-- The Scala `coerce` is the corresponding compiler.
--
{-# NON_TERMINATING #-}
coerce : (S : Data) → (T : Data) → uc S ∅ → Maybe (uc T ∅)

coerce (base m) (base n) s with m ≤? n
... | yes m≤n = just (Fin.inject≤ s m≤n)
... | no  m>n = nothing

coerce (pair S₁ S₂) (pair T₁ T₂) (s₁ , s₂) =
  coerce S₁ T₁ s₁ >>= (λ t₁ →
  coerce S₂ T₂ s₂ >>= (λ t₂ →
  return (t₁ , t₂)))

coerce (plus S₁ S₂) (plus T₁ T₂) (inj₁ s₁) =
  coerce S₁ T₁ s₁ >>= (λ t₁ → just (inj₁ t₁))

coerce (plus S₁ S₂) (plus T₁ T₂) (inj₂ s₂) =
  coerce S₂ T₂ s₂ >>= (λ t₂ → just (inj₂ t₂))

coerce (var j) T s =
  nothing -- should not happen

coerce (fix S) T (roll x) =
  let
    S′ = S [ 0 ↦ fix S ]
  in
    coerce S′ T (unsafeCast x)

coerce S (fix T) s =
  let
    T′ = T [ 0 ↦ fix T ]
  in
    coerce S T′ s >>= (λ t → just (roll (unsafeCast t)))

coerce _ _ _ = nothing

make agda spec of `coerce` terminating for contractive types


module New.Lang where

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Sum

open import New.Types public
open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public
open import Base.Data.DependentList public

module _ where
  data Const : (τ : Type) → Set where
  data Term (Γ : Context) :
    (τ : Type) → Set where
    -- constants aka. primitives
    const : ∀ {τ} →
      (c : Const τ) →
      Term Γ τ
    var : ∀ {τ} →
      (x : Var Γ τ) →
      Term Γ τ
    app : ∀ {σ τ}
      (s : Term Γ (σ ⇒ τ)) →
      (t : Term Γ σ) →
      Term Γ τ
    -- we use de Bruijn indicies, so we don't need binding occurrences.
    abs : ∀ {σ τ}
      (t : Term (σ • Γ) τ) →
      Term Γ (σ ⇒ τ)

  -- Weakening

  weaken : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Term Γ₁ τ →
    Term Γ₂ τ
  weaken Γ₁≼Γ₂ (const c) = const c
  weaken Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
  weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
  weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

open import Base.Denotation.Environment Type ⟦_⟧Type public

⟦_⟧Const : ∀ {τ} → Const τ → ⟦ τ ⟧Type
⟦_⟧Const ()

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → ⟦ τ ⟧Type
⟦ const c ⟧Term ρ = ⟦ c ⟧Const
⟦ var x ⟧Term ρ = ⟦ x ⟧Var ρ
⟦ app s t ⟧Term ρ = ⟦ s ⟧Term ρ (⟦ t ⟧Term ρ)
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)

open import Theorem.CongApp
open import Postulate.Extensionality

weaken-sound : ∀ {Γ₁ Γ₂ τ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
  (t : Term Γ₁ τ) (ρ : ⟦ Γ₂ ⟧Context) → ⟦ weaken Γ₁≼Γ₂ t ⟧Term ρ ≡ ⟦ t ⟧Term (⟦ Γ₁≼Γ₂ ⟧≼ ρ)
weaken-sound {Γ₁≼Γ₂ = Γ₁≼Γ₂} (var x) ρ = weaken-var-sound Γ₁≼Γ₂ x ρ
weaken-sound (app s t) ρ = weaken-sound s ρ ⟨$⟩ weaken-sound t ρ
weaken-sound (abs t) ρ = ext (λ v → weaken-sound t (v • ρ))
weaken-sound (const c) ρ = refl

module New.Lang where

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Sum

open import New.Types public
open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public
open import Base.Data.DependentList public

module _ where
  data Const : (τ : Type) → Set where
  data Term (Γ : Context) :
    (τ : Type) → Set where
    -- constants aka. primitives
    const : ∀ {τ} →
      (c : Const τ) →
      Term Γ τ
    var : ∀ {τ} →
      (x : Var Γ τ) →
      Term Γ τ
    app : ∀ {σ τ}
      (s : Term Γ (σ ⇒ τ)) →
      (t : Term Γ σ) →
      Term Γ τ
    -- we use de Bruijn indicies, so we don't need binding occurrences.
    abs : ∀ {σ τ}
      (t : Term (σ • Γ) τ) →
      Term Γ (σ ⇒ τ)

  -- Weakening

  weaken : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Term Γ₁ τ →
    Term Γ₂ τ
  weaken Γ₁≼Γ₂ (const c) = const c
  weaken Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
  weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
  weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

  -- Shorthands for nested applications
  app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
  app₂ f x = app (app f x)

  app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
  app₃ f x = app₂ (app f x)

  app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
  app₄ f x = app₃ (app f x)

  app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
  app₅ f x = app₄ (app f x)

  app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
  app₆ f x = app₅ (app f x)

open import Base.Denotation.Environment Type ⟦_⟧Type public

⟦_⟧Const : ∀ {τ} → Const τ → ⟦ τ ⟧Type
⟦_⟧Const ()

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → ⟦ τ ⟧Type
⟦ const c ⟧Term ρ = ⟦ c ⟧Const
⟦ var x ⟧Term ρ = ⟦ x ⟧Var ρ
⟦ app s t ⟧Term ρ = ⟦ s ⟧Term ρ (⟦ t ⟧Term ρ)
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)

open import Theorem.CongApp
open import Postulate.Extensionality

weaken-sound : ∀ {Γ₁ Γ₂ τ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
  (t : Term Γ₁ τ) (ρ : ⟦ Γ₂ ⟧Context) → ⟦ weaken Γ₁≼Γ₂ t ⟧Term ρ ≡ ⟦ t ⟧Term (⟦ Γ₁≼Γ₂ ⟧≼ ρ)
weaken-sound {Γ₁≼Γ₂ = Γ₁≼Γ₂} (var x) ρ = weaken-var-sound Γ₁≼Γ₂ x ρ
weaken-sound (app s t) ρ = weaken-sound s ρ ⟨$⟩ weaken-sound t ρ
weaken-sound (abs t) ρ = ext (λ v → weaken-sound t (v • ρ))
weaken-sound (const c) ρ = refl

Add helpers

Add helpers


module Popl14.Change.Specification where

-- Denotation-as-specification for Calculus Popl14
--
-- Contents
-- - ⟦_⟧Δ : binding-time-shifted derive
-- - Validity and correctness lemmas for ⟦_⟧Δ
-- - `corollary`: ⟦_⟧Δ reacts to both environment and arguments
-- - `corollary-closed`: binding-time-shifted main theorem

open import Popl14.Syntax.Term
open import Popl14.Denotation.Value
open import Popl14.Change.Validity
open import Popl14.Denotation.Evaluation public

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14
open import Theorem.Groups-Popl14
open import Theorem.CongApp
open import Postulate.Extensionality

⟦_⟧Δ : ∀ {τ Γ} → (t : Term Γ τ) (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) → Change τ (⟦ t ⟧ ρ)

correctness : ∀ {τ Γ} (t : Term Γ τ) (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ)
  → after {τ} (⟦ t ⟧Δ ρ dρ) ≡ ⟦ t ⟧ (update dρ)

⟦_⟧ΔVar : ∀ {τ Γ} → (x : Var Γ τ) → (ρ : ⟦ Γ ⟧) → ΔEnv Γ ρ → Change τ (⟦ x ⟧Var ρ)
⟦ this   ⟧ΔVar (v • ρ) (dv • dρ) = dv
⟦ that x ⟧ΔVar (v • ρ) (dv • dρ) = ⟦ x ⟧ΔVar ρ dρ

⟦_⟧Δ (intlit n) ρ dρ = + 0
⟦_⟧Δ (add s t) ρ dρ = ⟦ s ⟧Δ ρ dρ + ⟦ t ⟧Δ ρ dρ
⟦_⟧Δ (minus t) ρ dρ = - ⟦ t ⟧Δ ρ dρ
⟦_⟧Δ empty ρ dρ = emptyBag
⟦_⟧Δ (insert s t) ρ dρ =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δn = ⟦ s ⟧Δ ρ dρ
    Δb = ⟦ t ⟧Δ ρ dρ
  in
    (singletonBag (n ⊞₍ int ₎ Δn) ++ (b ⊞₍ bag ₎ Δb)) ⊟₍ bag ₎ (singletonBag n ++ b)
⟦_⟧Δ (union s t) ρ dρ = ⟦ s ⟧Δ ρ dρ ++ ⟦ t ⟧Δ ρ dρ
⟦_⟧Δ (negate t) ρ dρ = negateBag (⟦ t ⟧Δ ρ dρ)
⟦_⟧Δ (flatmap s t) ρ dρ =
  let
    f = ⟦ s ⟧ ρ
    b = ⟦ t ⟧ ρ
    Δf : Change (int ⇒ bag) f
    Δf = ⟦ s ⟧Δ ρ dρ
    Δb = ⟦ t ⟧Δ ρ dρ
  in
    flatmapBag (f ⊞₍ int ⇒ bag ₎ Δf) (b ⊞₍ bag ₎ Δb) ⊟₍ bag ₎ flatmapBag f b
⟦_⟧Δ (sum t) ρ dρ = sumBag (⟦ t ⟧Δ ρ dρ)
⟦_⟧Δ (var x) ρ dρ = ⟦ x ⟧ΔVar ρ dρ
⟦_⟧Δ (app {σ} {τ} s t) ρ dρ =
     call-change (⟦ s ⟧Δ ρ dρ) (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ)
⟦_⟧Δ (abs {σ} {τ} t) ρ dρ = cons
  (λ v dv → ⟦ t ⟧Δ (v • ρ) (dv • dρ))
  (λ v dv →
    begin
      ⟦ t ⟧ (v ⊞₍ σ ₎ dv • ρ)  ⊞₍ τ ₎
      ⟦ t ⟧Δ (v ⊞₍ σ ₎ dv • ρ) ((v ⊞₍ σ ₎ dv) ⊟₍ σ ₎ (v ⊞₍ σ ₎ dv) • dρ)
    ≡⟨  correctness t (v ⊞₍ σ ₎ dv • ρ) ((v ⊞₍ σ ₎ dv) ⊟₍ σ ₎ (v ⊞₍ σ ₎ dv) • dρ) ⟩
      ⟦ t ⟧ (update ((v ⊞₍ σ ₎ dv) ⊟₍ σ ₎ (v ⊞₍ σ ₎ dv) • dρ))
    ≡⟨⟩
      ⟦ t ⟧ (((v ⊞₍ σ ₎ dv) ⊞₍ σ ₎ ((v ⊞₍ σ ₎ dv) ⊟₍ σ ₎ (v ⊞₍ σ ₎ dv))) • update dρ)
    ≡⟨  cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ})  ⟩
      ⟦ t ⟧ (v ⊞₍ σ ₎ dv • update dρ)
    ≡⟨⟩
      ⟦ t ⟧ (update (dv • dρ))
    ≡⟨  sym (correctness t (v • ρ) (dv • dρ))  ⟩
      ⟦ t ⟧ (v • ρ)  ⊞₍ τ ₎  ⟦ t ⟧Δ (v • ρ) (dv • dρ)
    ∎) where open ≡-Reasoning

correctVar : ∀ {τ Γ} (x : Var Γ τ) (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) →
  ⟦ x ⟧ ρ ⊞₍ τ ₎ ⟦ x ⟧ΔVar ρ dρ ≡ ⟦ x ⟧ (update dρ)
correctVar (this) (v • ρ) (dv • dρ) = refl
correctVar (that y) (v • ρ) (dv • dρ) = correctVar y ρ dρ

correctness (intlit n) ρ dρ = right-id-int n
correctness (add s t) ρ dρ = trans
  (mn·pq=mp·nq
    {⟦ s ⟧ ρ} {⟦ t ⟧ ρ} {⟦ s ⟧Δ ρ dρ} {⟦ t ⟧Δ ρ dρ})
  (cong₂ _+_ (correctness s ρ dρ) (correctness t ρ dρ))
correctness (minus t) ρ dρ = trans
  (-m·-n=-mn {⟦ t ⟧ ρ} {⟦ t ⟧Δ ρ dρ})
  (cong -_ (correctness t ρ dρ))

correctness empty ρ dρ = right-id-bag emptyBag
correctness (insert s t) ρ dρ =
  let
    n = ⟦ s ⟧ ρ
    b = ⟦ t ⟧ ρ
    n′ = ⟦ s ⟧ (update dρ)
    b′ = ⟦ t ⟧ (update dρ)
    Δn = ⟦ s ⟧Δ ρ dρ
    Δb = ⟦ t ⟧Δ ρ dρ
  in
    begin
      (singletonBag n ++ b) ++
         (singletonBag (n ⊞₍ base base-int ₎ Δn) ++
           (b ⊞₍ base base-bag ₎ Δb)) \\ (singletonBag n ++ b)
    ≡⟨ a++[b\\a]=b ⟩
      singletonBag (n ⊞₍ base base-int ₎ Δn) ++
        (b ⊞₍ base base-bag ₎ Δb)
    ≡⟨ cong₂ _++_
         (cong singletonBag (correctness s ρ dρ))
         (correctness t ρ dρ) ⟩
      singletonBag n′ ++ b′
    ∎ where open ≡-Reasoning
correctness (union s t) ρ dρ = trans
  (ab·cd=ac·bd
    {⟦ s ⟧ ρ} {⟦ t ⟧ ρ} {⟦ s ⟧Δ ρ dρ} {⟦ t ⟧Δ ρ dρ})
  (cong₂ _++_ (correctness s ρ dρ) (correctness t ρ dρ))
correctness (negate t) ρ dρ = trans
  (-a·-b=-ab {⟦ t ⟧ ρ} {⟦ t ⟧Δ ρ dρ})
  (cong negateBag (correctness t ρ dρ))

correctness (flatmap s t) ρ dρ =
  let
    f = ⟦ s ⟧ ρ
    b = ⟦ t ⟧ ρ
    Δf = ⟦ s ⟧Δ ρ dρ
    Δb = ⟦ t ⟧Δ ρ dρ
  in trans
      (a++[b\\a]=b {flatmapBag f b}
        {flatmapBag (f ⊞₍ base base-int ⇒ base base-bag ₎ Δf)
                    (b ⊞₍ base base-bag ₎ Δb)})
      (cong₂ flatmapBag (correctness s ρ dρ) (correctness t ρ dρ))
correctness (sum t) ρ dρ =
  let
    b = ⟦ t ⟧ ρ
    Δb = ⟦ t ⟧Δ ρ dρ
  in
    trans (sym homo-sum) (cong sumBag (correctness t ρ dρ))

correctness {τ} (var x) ρ dρ = correctVar {τ} x ρ dρ
correctness (app {σ} {τ} s t) ρ dρ =
  let
    f = ⟦ s ⟧ ρ
    g = ⟦ s ⟧ (update dρ)
    u = ⟦ t ⟧ ρ
    v = ⟦ t ⟧ (update dρ)
    Δf = ⟦ s ⟧Δ ρ dρ
    Δu = ⟦ t ⟧Δ ρ dρ
  in
    begin
      f u ⊞₍ τ ₎ call-change Δf u Δu
    ≡⟨  sym (is-valid Δf u Δu) ⟩
       (f ⊞₍ σ ⇒ τ ₎ Δf) (u ⊞₍ σ ₎ Δu)
    ≡⟨ correctness {σ ⇒ τ} s ρ dρ ⟨$⟩ correctness {σ} t ρ dρ ⟩
      g v
    ∎ where open ≡-Reasoning
correctness {σ ⇒ τ} {Γ} (abs t) ρ dρ = ext (λ v →
  let
    -- dρ′ : ΔEnv (σ • Γ) (v • ρ)
    dρ′ = nil-change σ v • dρ
  in
    begin
      ⟦ t ⟧ (ignore dρ′) ⊞₍ τ ₎ ⟦ t ⟧Δ _ dρ′
    ≡⟨ correctness {τ} t _ dρ′ ⟩
      ⟦ t ⟧ (update dρ′)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (v • update dρ)
    ∎
  ) where open ≡-Reasoning

-- Corollary: (f ⊞ df) (v ⊞ dv) = f v ⊞ df v dv

corollary : ∀ {σ τ Γ}
  (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) →
    (⟦ s ⟧ ρ ⊞₍ σ ⇒ τ ₎ ⟦ s ⟧Δ ρ dρ)
      (⟦ t ⟧ ρ ⊞₍ σ ₎ ⟦ t ⟧Δ ρ dρ)
  ≡ (⟦ s ⟧ ρ) (⟦ t ⟧ ρ)
    ⊞₍ τ ₎
    (call-change (⟦ s ⟧Δ ρ dρ)) (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ)

corollary {σ} {τ} s t ρ dρ =
  is-valid (⟦ s ⟧Δ ρ dρ) (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ)

corollary-closed : ∀ {σ τ} (t : Term ∅ (σ ⇒ τ))
  (v : ⟦ σ ⟧) (dv : Change σ v)
  → ⟦ t ⟧ ∅ (after {σ} dv)
  ≡ ⟦ t ⟧ ∅ v ⊞₍ τ ₎ call-change (⟦ t ⟧Δ ∅ ∅) v dv

corollary-closed {σ} {τ} t v dv =
  let
    f  = ⟦ t ⟧ ∅
    Δf = ⟦ t ⟧Δ ∅ ∅
  in
    begin
      f (after {σ} dv)
    ≡⟨ cong (λ hole → hole (after {σ} dv))
            (sym (correctness {σ ⇒ τ} t ∅ ∅)) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (after {σ} dv)
    ≡⟨ is-valid (⟦ t ⟧Δ ∅ ∅) v dv ⟩
      f (before {σ} dv) ⊞₍ τ ₎ call-change Δf v dv
    ∎ where open ≡-Reasoning

module Popl14.Change.Specification where

-- Denotation-as-specification for Calculus Popl14
--
-- Contents
-- - ⟦_⟧Δ : binding-time-shifted derive
-- - Validity and correctness lemmas for ⟦_⟧Δ
-- - `corollary`: ⟦_⟧Δ reacts to both environment and arguments
-- - `corollary-closed`: binding-time-shifted main theorem

open import Popl14.Syntax.Term
open import Popl14.Denotation.Value
open import Popl14.Change.Validity
open import Popl14.Denotation.Evaluation public

open import Relation.Binary.PropositionalEquality
open import Data.Integer
open import Theorem.Groups-Popl14
open import Theorem.CongApp
open import Postulate.Extensionality

⟦_⟧Δ : ∀ {τ Γ} → (t : Term Γ τ) (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) → Change τ (⟦ t ⟧ ρ)

correctness : ∀ {τ Γ} (t : Term Γ τ) (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ)
  → after {τ} (⟦ t ⟧Δ ρ dρ) ≡ ⟦ t ⟧ (update dρ)

⟦_⟧ΔVar : ∀ {τ Γ} → (x : Var Γ τ) → (ρ : ⟦ Γ ⟧) → ΔEnv Γ ρ → Change τ (⟦ x ⟧Var ρ)
⟦ this   ⟧ΔVar (v • ρ) (dv • dρ) = dv
⟦ that x ⟧ΔVar (v • ρ) (dv • dρ) = ⟦ x ⟧ΔVar ρ dρ

⟦_⟧Δ (intlit n) ρ dρ = + 0
⟦_⟧Δ (add s t) ρ dρ = ⟦ s ⟧Δ ρ dρ + ⟦ t ⟧Δ ρ dρ
⟦_⟧Δ (minus t) ρ dρ = - ⟦ t ⟧Δ ρ dρ
⟦_⟧Δ empty ρ dρ = emptyBag
⟦_⟧Δ (insert s t) ρ dρ =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δn = ⟦ s ⟧Δ ρ dρ
    Δb = ⟦ t ⟧Δ ρ dρ
  in
    (singletonBag (n ⊞₍ int ₎ Δn) ++ (b ⊞₍ bag ₎ Δb)) ⊟₍ bag ₎ (singletonBag n ++ b)
⟦_⟧Δ (union s t) ρ dρ = ⟦ s ⟧Δ ρ dρ ++ ⟦ t ⟧Δ ρ dρ
⟦_⟧Δ (negate t) ρ dρ = negateBag (⟦ t ⟧Δ ρ dρ)
⟦_⟧Δ (flatmap s t) ρ dρ =
  let
    f = ⟦ s ⟧ ρ
    b = ⟦ t ⟧ ρ
    Δf : Change (int ⇒ bag) f
    Δf = ⟦ s ⟧Δ ρ dρ
    Δb = ⟦ t ⟧Δ ρ dρ
  in
    flatmapBag (f ⊞₍ int ⇒ bag ₎ Δf) (b ⊞₍ bag ₎ Δb) ⊟₍ bag ₎ flatmapBag f b
⟦_⟧Δ (sum t) ρ dρ = sumBag (⟦ t ⟧Δ ρ dρ)
⟦_⟧Δ (var x) ρ dρ = ⟦ x ⟧ΔVar ρ dρ
⟦_⟧Δ (app {σ} {τ} s t) ρ dρ =
     call-change (⟦ s ⟧Δ ρ dρ) (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ)
⟦_⟧Δ (abs {σ} {τ} t) ρ dρ = cons
  (λ v dv → ⟦ t ⟧Δ (v • ρ) (dv • dρ))
  (λ v dv →
    begin
      ⟦ t ⟧ (v ⊞₍ σ ₎ dv • ρ)  ⊞₍ τ ₎
      ⟦ t ⟧Δ (v ⊞₍ σ ₎ dv • ρ) ((v ⊞₍ σ ₎ dv) ⊟₍ σ ₎ (v ⊞₍ σ ₎ dv) • dρ)
    ≡⟨  correctness t (v ⊞₍ σ ₎ dv • ρ) ((v ⊞₍ σ ₎ dv) ⊟₍ σ ₎ (v ⊞₍ σ ₎ dv) • dρ) ⟩
      ⟦ t ⟧ (update ((v ⊞₍ σ ₎ dv) ⊟₍ σ ₎ (v ⊞₍ σ ₎ dv) • dρ))
    ≡⟨⟩
      ⟦ t ⟧ (((v ⊞₍ σ ₎ dv) ⊞₍ σ ₎ ((v ⊞₍ σ ₎ dv) ⊟₍ σ ₎ (v ⊞₍ σ ₎ dv))) • update dρ)
    ≡⟨  cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ})  ⟩
      ⟦ t ⟧ (v ⊞₍ σ ₎ dv • update dρ)
    ≡⟨⟩
      ⟦ t ⟧ (update (dv • dρ))
    ≡⟨  sym (correctness t (v • ρ) (dv • dρ))  ⟩
      ⟦ t ⟧ (v • ρ)  ⊞₍ τ ₎  ⟦ t ⟧Δ (v • ρ) (dv • dρ)
    ∎) where open ≡-Reasoning

correctVar : ∀ {τ Γ} (x : Var Γ τ) (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) →
  ⟦ x ⟧ ρ ⊞₍ τ ₎ ⟦ x ⟧ΔVar ρ dρ ≡ ⟦ x ⟧ (update dρ)
correctVar (this) (v • ρ) (dv • dρ) = refl
correctVar (that y) (v • ρ) (dv • dρ) = correctVar y ρ dρ

correctness (intlit n) ρ dρ = right-id-int n
correctness (add s t) ρ dρ = trans
  (mn·pq=mp·nq
    {⟦ s ⟧ ρ} {⟦ t ⟧ ρ} {⟦ s ⟧Δ ρ dρ} {⟦ t ⟧Δ ρ dρ})
  (cong₂ _+_ (correctness s ρ dρ) (correctness t ρ dρ))
correctness (minus t) ρ dρ = trans
  (-m·-n=-mn {⟦ t ⟧ ρ} {⟦ t ⟧Δ ρ dρ})
  (cong -_ (correctness t ρ dρ))

correctness empty ρ dρ = right-id-bag emptyBag
correctness (insert s t) ρ dρ =
  let
    n = ⟦ s ⟧ ρ
    b = ⟦ t ⟧ ρ
    n′ = ⟦ s ⟧ (update dρ)
    b′ = ⟦ t ⟧ (update dρ)
    Δn = ⟦ s ⟧Δ ρ dρ
    Δb = ⟦ t ⟧Δ ρ dρ
  in
    begin
      (singletonBag n ++ b) ++
         (singletonBag (n ⊞₍ base base-int ₎ Δn) ++
           (b ⊞₍ base base-bag ₎ Δb)) \\ (singletonBag n ++ b)
    ≡⟨ a++[b\\a]=b ⟩
      singletonBag (n ⊞₍ base base-int ₎ Δn) ++
        (b ⊞₍ base base-bag ₎ Δb)
    ≡⟨ cong₂ _++_
         (cong singletonBag (correctness s ρ dρ))
         (correctness t ρ dρ) ⟩
      singletonBag n′ ++ b′
    ∎ where open ≡-Reasoning
correctness (union s t) ρ dρ = trans
  (ab·cd=ac·bd
    {⟦ s ⟧ ρ} {⟦ t ⟧ ρ} {⟦ s ⟧Δ ρ dρ} {⟦ t ⟧Δ ρ dρ})
  (cong₂ _++_ (correctness s ρ dρ) (correctness t ρ dρ))
correctness (negate t) ρ dρ = trans
  (-a·-b=-ab {⟦ t ⟧ ρ} {⟦ t ⟧Δ ρ dρ})
  (cong negateBag (correctness t ρ dρ))

correctness (flatmap s t) ρ dρ =
  let
    f = ⟦ s ⟧ ρ
    b = ⟦ t ⟧ ρ
    Δf = ⟦ s ⟧Δ ρ dρ
    Δb = ⟦ t ⟧Δ ρ dρ
  in trans
      (a++[b\\a]=b {flatmapBag f b}
        {flatmapBag (f ⊞₍ base base-int ⇒ base base-bag ₎ Δf)
                    (b ⊞₍ base base-bag ₎ Δb)})
      (cong₂ flatmapBag (correctness s ρ dρ) (correctness t ρ dρ))
correctness (sum t) ρ dρ =
  let
    b = ⟦ t ⟧ ρ
    Δb = ⟦ t ⟧Δ ρ dρ
  in
    trans (sym homo-sum) (cong sumBag (correctness t ρ dρ))

correctness {τ} (var x) ρ dρ = correctVar {τ} x ρ dρ
correctness (app {σ} {τ} s t) ρ dρ =
  let
    f = ⟦ s ⟧ ρ
    g = ⟦ s ⟧ (update dρ)
    u = ⟦ t ⟧ ρ
    v = ⟦ t ⟧ (update dρ)
    Δf = ⟦ s ⟧Δ ρ dρ
    Δu = ⟦ t ⟧Δ ρ dρ
  in
    begin
      f u ⊞₍ τ ₎ call-change Δf u Δu
    ≡⟨  sym (is-valid Δf u Δu) ⟩
       (f ⊞₍ σ ⇒ τ ₎ Δf) (u ⊞₍ σ ₎ Δu)
    ≡⟨ correctness {σ ⇒ τ} s ρ dρ ⟨$⟩ correctness {σ} t ρ dρ ⟩
      g v
    ∎ where open ≡-Reasoning
correctness {σ ⇒ τ} {Γ} (abs t) ρ dρ = ext (λ v →
  let
    -- dρ′ : ΔEnv (σ • Γ) (v • ρ)
    dρ′ = nil-change σ v • dρ
  in
    begin
      ⟦ t ⟧ (ignore dρ′) ⊞₍ τ ₎ ⟦ t ⟧Δ _ dρ′
    ≡⟨ correctness {τ} t _ dρ′ ⟩
      ⟦ t ⟧ (update dρ′)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (v • update dρ)
    ∎
  ) where open ≡-Reasoning

-- Corollary: (f ⊞ df) (v ⊞ dv) = f v ⊞ df v dv

corollary : ∀ {σ τ Γ}
  (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) →
    (⟦ s ⟧ ρ ⊞₍ σ ⇒ τ ₎ ⟦ s ⟧Δ ρ dρ)
      (⟦ t ⟧ ρ ⊞₍ σ ₎ ⟦ t ⟧Δ ρ dρ)
  ≡ (⟦ s ⟧ ρ) (⟦ t ⟧ ρ)
    ⊞₍ τ ₎
    (call-change (⟦ s ⟧Δ ρ dρ)) (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ)

corollary {σ} {τ} s t ρ dρ =
  is-valid (⟦ s ⟧Δ ρ dρ) (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ)

corollary-closed : ∀ {σ τ} (t : Term ∅ (σ ⇒ τ))
  (v : ⟦ σ ⟧) (dv : Change σ v)
  → ⟦ t ⟧ ∅ (after {σ} dv)
  ≡ ⟦ t ⟧ ∅ v ⊞₍ τ ₎ call-change (⟦ t ⟧Δ ∅ ∅) v dv

corollary-closed {σ} {τ} t v dv =
  let
    f  = ⟦ t ⟧ ∅
    Δf = ⟦ t ⟧Δ ∅ ∅
  in
    begin
      f (after {σ} dv)
    ≡⟨ cong (λ hole → hole (after {σ} dv))
            (sym (correctness {σ ⇒ τ} t ∅ ∅)) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (after {σ} dv)
    ≡⟨ is-valid (⟦ t ⟧Δ ∅ ∅) v dv ⟩
      f (before {σ} dv) ⊞₍ τ ₎ call-change Δf v dv
    ∎ where open ≡-Reasoning

Remove unnecessary imports.

Remove unnecessary imports.

Old-commit-hash: 01c6cb718906e9a41b8156076fe9e837257c7a1f


module PLDI14-List-of-Theorems where

open import Function

-- List of theorems in PLDI submission
--
-- For hints about installation and execution, please refer
-- to README.agda.
--
-- Agda modules corresponding to definitions, lemmas and theorems
-- are listed here with the most important name. For example,
-- after this file type checks (C-C C-L), placing the cursor
-- on the purple "Base.Change.Algebra" and pressing M-. will
-- bring you to the file where change structures are defined.
-- The name for change structures in that file is
-- "ChangeAlgebra", given in the using-clause.

-- Definition 2.1 (Change structures)
-- (d) ChangeAlgebra.diff
-- (e) IsChangeAlgebra.update-diff
open import Base.Change.Algebra using (ChangeAlgebra)
---- Carrier in record ChangeAlgebra                        --(a)
open Base.Change.Algebra.ChangeAlgebra   using (Change)     --(b)
open Base.Change.Algebra.ChangeAlgebra   using (update)     --(c)
open Base.Change.Algebra.ChangeAlgebra   using (diff)       --(d)
open Base.Change.Algebra.IsChangeAlgebra using (update-diff)--(e)

-- Definition 2.2 (Nil change)
-- IsChangeAlgebra.nil
open Base.Change.Algebra using (IsChangeAlgebra)

-- Lemma 2.3 (Behavior of nil)
-- IsChangeAlgebra.update-nil
open Base.Change.Algebra using (IsChangeAlgebra)

-- Definition 2.4 (Derivatives)
open Base.Change.Algebra using (Derivative)

-- Definition 2.5 (Carrier set of function changes)
open Base.Change.Algebra.FunctionChanges

-- Definition 2.6 (Operations on function changes)
-- ChangeAlgebra.update FunctionChanges.changeAlgebra
-- ChangeAlgebra.diff   FunctionChanges.changeAlgebra
open Base.Change.Algebra.FunctionChanges using (changeAlgebra)

-- Theorem 2.7 (Function changes form a change structure)
-- (In Agda, the proof of Theorem 2.7 has to be included in the
-- definition of function changes, here
-- FunctionChanges.changeAlgebra.)
open Base.Change.Algebra.FunctionChanges using (changeAlgebra)

-- Lemma 2.8 (Incrementalization)
open Base.Change.Algebra.FunctionChanges using (incrementalization)

-- Theorem 2.9 (Nil changes are derivatives)
open Base.Change.Algebra.FunctionChanges using (nil-is-derivative)

-- For each plugin requirement, we include its definition and
-- a concrete instantiation called "Popl14" with integers and
-- bags of integers as base types.

-- Plugin Requirement 3.1 (Domains of base types)
open import Parametric.Denotation.Value using (Structure)
open import     Popl14.Denotation.Value using (⟦_⟧Base)

-- Definition 3.2 (Domains)
open Parametric.Denotation.Value.Structure using (⟦_⟧Type)

-- Plugin Requirement 3.3 (Evaluation of constants)
open import Parametric.Denotation.Evaluation using (Structure)
open import     Popl14.Denotation.Evaluation using (⟦_⟧Const)

-- Definition 3.4 (Environments)
open import Base.Denotation.Environment using (⟦_⟧Context)

-- Definition 3.5 (Evaluation)
open Parametric.Denotation.Evaluation.Structure using (⟦_⟧Term)

-- Plugin Requirement 3.6 (Changes on base types)
open import Parametric.Change.Validity using (Structure)
open import     Popl14.Change.Validity using (change-algebra-base-family)

-- Definition 3.7 (Changes)
open Parametric.Change.Validity.Structure using (change-algebra)

-- Definition 3.8 (Change environments)
open Parametric.Change.Validity.Structure using (environment-changes)

-- Plugin Requirement 3.9 (Change semantics for constants)
open import Parametric.Change.Specification using (Structure)
open import     Popl14.Change.Specification using (specification-structure)

-- Definition 3.10 (Change semantics)
open Parametric.Change.Specification.Structure using (⟦_⟧Δ)

-- Lemma 3.11 (Change semantics is the derivative of semantics)
open Parametric.Change.Specification.Structure using (correctness)

-- Definition 3.12 (Erasure)
import Parametric.Change.Implementation
open Parametric.Change.Implementation.Structure using (_≈_)
open import Popl14.Change.Implementation using (implements-base)

-- Lemma 3.13 (The erased version of a change is almost the same)
open Parametric.Change.Implementation.Structure using (carry-over)

-- Lemma 3.14 (⟦ t ⟧Δ erases to Derive(t))
import Parametric.Change.Correctness
open Parametric.Change.Correctness.Structure using (main-theorem)

module PLDI14-List-of-Theorems where

open import Function

-- List of theorems in PLDI submission
--
-- For hints about installation and execution, please refer
-- to README.agda.
--
-- Agda modules corresponding to definitions, lemmas and theorems
-- are listed here with the most important name. For example,
-- after this file type checks (C-C C-L), placing the cursor
-- on the purple "Base.Change.Algebra" and pressing M-. will
-- bring you to the file where change structures are defined.
-- The name for change structures in that file is
-- "ChangeAlgebra", given in the using-clause.

-- Definition 2.1 (Change structures)
-- (d) ChangeAlgebra.diff
-- (e) IsChangeAlgebra.update-diff
open import Base.Change.Algebra using (ChangeAlgebra)
---- Carrier in record ChangeAlgebra                        --(a)
open Base.Change.Algebra.ChangeAlgebra   using (Change)     --(b)
open Base.Change.Algebra.ChangeAlgebra   using (update)     --(c)
open Base.Change.Algebra.ChangeAlgebra   using (diff)       --(d)
open Base.Change.Algebra.IsChangeAlgebra using (update-diff)--(e)

-- Definition 2.2 (Nil change)
-- IsChangeAlgebra.nil
open Base.Change.Algebra using (IsChangeAlgebra)

-- Lemma 2.3 (Behavior of nil)
-- IsChangeAlgebra.update-nil
open Base.Change.Algebra using (IsChangeAlgebra)

-- Definition 2.4 (Derivatives)
open Base.Change.Algebra using (Derivative)

-- Definition 2.5 (Carrier set of function changes)
open Base.Change.Algebra.FunctionChanges

-- Definition 2.6 (Operations on function changes)
-- ChangeAlgebra.update FunctionChanges.changeAlgebra
-- ChangeAlgebra.diff   FunctionChanges.changeAlgebra
open Base.Change.Algebra.FunctionChanges using (changeAlgebra)

-- Theorem 2.7 (Function changes form a change structure)
-- (In Agda, the proof of Theorem 2.7 has to be included in the
-- definition of function changes, here
-- FunctionChanges.changeAlgebra.)
open Base.Change.Algebra.FunctionChanges using (changeAlgebra)

-- Lemma 2.8 (Incrementalization)
open Base.Change.Algebra.FunctionChanges using (incrementalization)

-- Theorem 2.9 (Nil changes are derivatives)
open Base.Change.Algebra.FunctionChanges using (nil-is-derivative)

-- For each plugin requirement, we include its definition and
-- a concrete instantiation called "Popl14" with integers and
-- bags of integers as base types.

-- Plugin Requirement 3.1 (Domains of base types)
open import Parametric.Denotation.Value using (Structure)
open import     Popl14.Denotation.Value using (⟦_⟧Base)

-- Definition 3.2 (Domains)
open Parametric.Denotation.Value.Structure using (⟦_⟧Type)

-- Plugin Requirement 3.3 (Evaluation of constants)
open import Parametric.Denotation.Evaluation using (Structure)
open import     Popl14.Denotation.Evaluation using (⟦_⟧Const)

-- Definition 3.4 (Environments)
open import Base.Denotation.Environment using (⟦_⟧Context)

-- Definition 3.5 (Evaluation)
open Parametric.Denotation.Evaluation.Structure using (⟦_⟧Term)

-- Plugin Requirement 3.6 (Changes on base types)
open import Parametric.Change.Validity using (Structure)
open import     Popl14.Change.Validity using (change-algebra-base-family)

-- Definition 3.7 (Changes)
open Parametric.Change.Validity.Structure using (change-algebra)

-- Definition 3.8 (Change environments)
open Parametric.Change.Validity.Structure using (environment-changes)

-- Plugin Requirement 3.9 (Change semantics for constants)
open import Parametric.Change.Specification using (Structure)
open import     Popl14.Change.Specification using (specification-structure)

-- Definition 3.10 (Change semantics)
open Parametric.Change.Specification.Structure using (⟦_⟧Δ)

-- Lemma 3.11 (Change semantics is the derivative of semantics)
open Parametric.Change.Specification.Structure using (correctness)

-- Definition 3.12 (Erasure)
import Parametric.Change.Implementation
open Parametric.Change.Implementation.Structure using (_≈_)
open import Popl14.Change.Implementation using (implements-base)

-- Lemma 3.13 (The erased version of a change is almost the same)
open Parametric.Change.Implementation.Structure using (carry-over)

-- Lemma 3.14 (⟦ t ⟧Δ erases to Derive(t))
import Parametric.Change.Correctness
open Parametric.Change.Correctness.Structure using (derive-correct-closed)

-- Theorem 3.15 (Correctness of differentiation)
open Parametric.Change.Correctness.Structure using (main-theorem)

correct list of theorems

correct list of theorems

Old-commit-hash: c915c2bba4a8fd18c2b4d5af429fdedf6042ca83


module Algebra.Field where

open import Relation.Binary.PropositionalEquality.NP
import Algebra.FunctionProperties.Eq as FP
open import Data.Nat.NP using (ℕ; zero; suc; fold)
import Data.Integer as ℤ
open ℤ using (ℤ)

record Field-Ops {ℓ} (A : Set ℓ) : Set ℓ where
  infixl 6 _+_ _−_
  infixl 7 _*_ _/_

  field
    _+_ _*_     : A → A → A
    0ᶠ 1ᶠ        : A
    0-_         : A → A
    _⁻¹         : A → A

  _−_ _/_ : A → A → A
  a − b = a + 0- b
  a / b = a * b ⁻¹

  -0ᶠ -1ᶠ : A
  -0ᶠ = 0- 0ᶠ
  -1ᶠ = 0- 1ᶠ

  sucᶠ : A → A
  sucᶠ = _+_ 1ᶠ

  predᶠ : A → A
  predᶠ x = x − 1ᶠ

  ℕ[_] : ℕ → A
  ℕ[_] = fold 0ᶠ sucᶠ

  ℤ[_] : ℤ → A
  ℤ[ ℤ.+ x      ] = ℕ[ x ]
  ℤ[ ℤ.-[1+ x ] ] = 0- ℕ[ suc x ]

  _^ℕ_ : A → ℕ → A
  b ^ℕ e = fold 1ᶠ (_*_ b) e

  _^ℤ_ : A → ℤ → A
  b ^ℤ (ℤ.+ x)    = b ^ℕ x
  b ^ℤ ℤ.-[1+ x ] = (b ^ℕ (suc x))⁻¹

record Field-Struct {ℓ} {A : Set ℓ} (field-ops : Field-Ops A) : Set ℓ where
  open FP {ℓ} {A}
  open Field-Ops field-ops

  field
    0≢1         : 0ᶠ ≢ 1ᶠ
    +-assoc     : Associative _+_
    *-assoc     : Associative _*_
    +-comm      : Commutative _+_
    *-comm      : Commutative _*_
    0+-identity : LeftIdentity 0ᶠ _+_
    1*-identity : LeftIdentity 1ᶠ _*_
    0--inverse  : LeftInverse 0ᶠ 0-_ _+_
    ⁻¹-inverse  : ∀ {x} → x ≢ 0ᶠ → x ⁻¹ * x ≡ 1ᶠ
    *-+-distr   : _*_ DistributesOverˡ _+_

  0--right-inverse : RightInverse 0ᶠ 0-_ _+_
  0--right-inverse = +-comm ∙ 0--inverse

  ⁻¹-right-inverse  : ∀ {x} → x ≢ 0ᶠ → x * x ⁻¹ ≡ 1ᶠ
  ⁻¹-right-inverse p = *-comm ∙ ⁻¹-inverse p

  +0-identity : RightIdentity 0ᶠ _+_
  +0-identity = +-comm ∙ 0+-identity

  *1-identity : RightIdentity 1ᶠ _*_
  *1-identity = *-comm ∙ 1*-identity

  += : ∀ {x x' y y'} → x ≡ x' → y ≡ y' → x + y ≡ x' + y'
  += {x} {y' = y'} p q = ap (_+_ x) q ∙ ap (λ z → z + y') p

  *= : ∀ {x x' y y'} → x ≡ x' → y ≡ y' → x * y ≡ x' * y'
  *= {x} {y' = y'} p q = ap (_*_ x) q ∙ ap (λ z → z * y') p

  0-c+c+x : ∀ {c x} → 0- c + c + x ≡ x
  0-c+c+x = += 0--inverse refl ∙ 0+-identity

  +-left-cancel : LeftCancel _+_
  +-left-cancel p = ! 0-c+c+x ∙ +-assoc
                  ∙ ap (λ z → 0- _ + z) p
                  ∙ ! +-assoc ∙ 0-c+c+x

  +-right-cancel : RightCancel _+_
  +-right-cancel p = +-left-cancel (+-comm ∙ p ∙ +-comm)

  0--involutive : Involutive 0-_
  0--involutive = +-left-cancel (0--right-inverse ∙ ! 0--inverse)

  -0≡0 : -0ᶠ ≡ 0ᶠ
  -0≡0 = +-left-cancel (0--right-inverse ∙ ! 0+-identity)

  open Field-Ops field-ops public

record Field {ℓ} (A : Set ℓ) : Set ℓ where
  field
    field-ops    : Field-Ops A
    field-struct : Field-Struct field-ops
  open Field-Struct field-struct public

open import Reflection.NP
open import Data.List
open import Data.Maybe.NP

module TermField {a} {A : Set a} (F : Field A) where
  open Field F
  pattern _`+_ t u = con (quote _+_) (argᵛʳ t ∷ argᵛʳ u ∷ [])
  pattern _`*_ t u = con (quote _*_) (argᵛʳ t ∷ argᵛʳ u ∷ [])
  pattern `0-_ t = conᵛʳ (quote 0-_) t
  pattern _`⁻¹ t = conᵛʳ (quote _⁻¹) t
  pattern `0ᶠ = con (quote 0ᶠ) []
  pattern `1ᶠ = con (quote 1ᶠ) []

  module Decode-RawField {b}{B : Set b}(G : Field-Ops B)(default : Decode-Term B) where
    module G = Field-Ops G
    decode-Field : Decode-Term B
    decode-Field `0ᶠ = just G.0ᶠ
    decode-Field `1ᶠ = just G.1ᶠ
    decode-Field (t `⁻¹) = map? G._⁻¹ (decode-Field t)
    decode-Field (`0- t) = map? G.0-_ (decode-Field t)
    decode-Field (t `+ u) = ⟪ G._+_ · decode-Field t · decode-Field u ⟫?
    decode-Field (t `* u) = ⟪ G._*_ · decode-Field t · decode-Field u ⟫?
    decode-Field t = default t

open ≡-Reasoning
open import Data.List

infixl 6 _+'_
infixl 7 _*'_
data Tm (A : Set) : Set where
  lit       : (n : ℤ) → Tm A
  var       : (x : A) → Tm A
  _+'_ _*'_ : Tm A → Tm A → Tm A

pattern  0' = lit (ℤ.+ 0)
pattern  1' = lit (ℤ.+ 1)
pattern  2' = lit (ℤ.+ 1)
pattern  3' = lit (ℤ.+ 1)
pattern -1' = lit ℤ.-[1+ 0 ]
pattern -2' = lit ℤ.-[1+ 1 ]
pattern -3' = lit ℤ.-[1+ 2 ]

record Var (A : Set) : Set where
  constructor _^'_
  field
    v : A
    e : ℤ

data Nf' (A : Set) : Set where
  _*'_ : (n : ℤ) (vs : List (Var A)) → Nf' A

data Nf (A : Set) : Set where
  _+'_ : (n : ℤ) (ts' : List (Nf' A)) → Nf A

module _ {A : Set} where
    infixl 6 _+ᴺ_

    litᴺ : ℤ → Nf A
    litᴺ n = n +' []

    varᴺ : (x : A) → Nf A
    varᴺ x = ℤ.+ 0 +' (ℤ.+ 1 *' (x ^' (ℤ.+ 1) ∷ []) ∷ [])

    _+ᴺ_ : Nf A → Nf A → Nf A
    (n +' ts) +ᴺ (m +' us) = n ℤ.+ m +' (ts ++ us)

    infixl 7 _**_ _***_ _*ᴺ_
    _**_ : ℤ → List (Nf' A) → Nf A
    z ** [] = z +' []
    m ** (n *' vs ∷ ts) with m ** ts
    ... | z +' us = z +' ((m ℤ.* n) *' vs ∷ us)

    _***_ : List (Nf' A) → List (Nf' A) → Nf A
    ts *** us = ℤ.+ 0 +' (ts ++ us)

    _*ᴺ_ : Nf A → Nf A → Nf A
    (n +' ts) *ᴺ (m +' us) =
       n ℤ.* m +' [] +ᴺ n ** us +ᴺ m ** ts +ᴺ ts *** us

module Normalizer {F : Set}
                  (F-field : Field F) where
    open Field F-field renaming (0-_ to -_)

    module _ {A : Set} where
        eval : (A → F) → Tm A → F
        eval ρ (lit x) = ℤ[ x ]
        eval ρ (t +' t₁) = eval ρ t + eval ρ t₁
        eval ρ (t *' t₁) = eval ρ t * eval ρ t₁
        eval ρ (var x)  = ρ x

        norm™ : Tm A → Nf A
        norm™ (lit x) = litᴺ x
        norm™ (var x) = varᴺ x
        norm™ (t +' t₁) = norm™ t +ᴺ norm™ t₁
        norm™ (t *' t₁) = norm™ t *ᴺ norm™ t₁

        _+''_ : Tm A → Tm A → Tm A
        -- lit (ℤ.+ 0) +'' u = u
        t +'' lit (ℤ.+ 0) = t
        t +'' u = t +' u

        _*''_ : Tm A → Tm A → Tm A
        -- lit (ℤ.+ 0) *'' u = lit (ℤ.+ 0)
        -- lit (ℤ.-[1+_] 0) *'' u = lit (ℤ.+ 0)
        t *'' lit (ℤ.+ 0) = lit (ℤ.+ 0)
        t *'' lit (ℤ.-[1+_] 0) = lit (ℤ.+ 0)
        -- lit (ℤ.+ 1) *'' u = u
        t *'' lit (ℤ.+ 1) = t
        t *'' u           = t *' u

        reifyVar : Var A → Tm A
        reifyVar (v ^' (ℤ.+ n))    = fold (lit (ℤ.+ 1)) (λ x → var v *'' x) n
        reifyVar (v ^' ℤ.-[1+ n ]) = fold (lit (ℤ.-[1+_] 1)) (λ x → var v *'' x) n

        reifyNf' : Nf' A → Tm A
        reifyNf' (n *' vs) = foldr (λ v t → reifyVar v *'' t) (lit n) vs

        reifyNf : Nf A → Tm A
        reifyNf (n +' ts') = foldr (λ n t → reifyNf' n +'' t) (lit n) ts'

        module _ ρ where
            _∼_ : (t u : Tm A) → Set
            t ∼ u = eval ρ t ≡ eval ρ u

            +'∼+'' : ∀ t u → (t +' u) ∼ (t +'' u)
            +'∼+'' t (lit (ℤ.+ zero)) = +0-identity
            +'∼+'' t (lit (ℤ.+ (suc x))) = refl
            +'∼+'' t (lit ℤ.-[1+ x ]) = refl
            +'∼+'' t (var x) = refl
            +'∼+'' t (u +' u₁) = refl
            +'∼+'' t (u *' u₁) = refl

            {-
            +-reifyNf : ∀ t u → reifyNf (t +ᴺ u) ∼ (reifyNf t +' reifyNf u)
            +-reifyNf (n +' ts') (n₁ +' ts'') = {!!}

            *-reifyNf : ∀ t u → reifyNf (t *ᴺ u) ∼ (reifyNf t *' reifyNf u)
            *-reifyNf t u = {!!}

            pf : ∀ t → eval ρ (reifyNf (norm™ t)) ≡ eval ρ t
            pf (lit n) = refl
            pf (var x) = refl
            pf (t +' t₁) rewrite +-reifyNf (norm™ t) (norm™ t₁) | pf t | pf t₁ = refl
            pf (t *' t₁) rewrite *-reifyNf (norm™ t) (norm™ t₁) | pf t | pf t₁ = refl
            -}
-- -}
-- -}
-- -}
-- -}
-- -}

module Algebra.Field where

open import Relation.Binary.PropositionalEquality.NP
import Algebra.FunctionProperties.Eq as FP
open import Data.Nat.NP using (ℕ; zero; suc; fold)
import Data.Integer as ℤ
open ℤ using (ℤ)

record Field-Ops {ℓ} (A : Set ℓ) : Set ℓ where
  infixl 6 _+_ _−_
  infixl 7 _*_ _/_

  field
    _+_ _*_     : A → A → A
    0ᶠ 1ᶠ        : A
    0-_         : A → A
    _⁻¹         : A → A

  _−_ _/_ : A → A → A
  a − b = a + 0- b
  a / b = a * b ⁻¹

  -0ᶠ -1ᶠ : A
  -0ᶠ = 0- 0ᶠ
  -1ᶠ = 0- 1ᶠ

  sucᶠ : A → A
  sucᶠ = _+_ 1ᶠ

  predᶠ : A → A
  predᶠ x = x − 1ᶠ

  ℕ[_] : ℕ → A
  ℕ[_] = fold 0ᶠ sucᶠ

  ℤ[_] : ℤ → A
  ℤ[ ℤ.+ x      ] = ℕ[ x ]
  ℤ[ ℤ.-[1+ x ] ] = 0- ℕ[ suc x ]

  _^ℕ_ : A → ℕ → A
  b ^ℕ e = fold 1ᶠ (_*_ b) e

  _^ℤ_ : A → ℤ → A
  b ^ℤ (ℤ.+ x)    = b ^ℕ x
  b ^ℤ ℤ.-[1+ x ] = (b ^ℕ (suc x))⁻¹

record Field-Struct {ℓ} {A : Set ℓ} (field-ops : Field-Ops A) : Set ℓ where
  open FP {ℓ} {A}
  open Field-Ops field-ops

  field
    0≢1         : 0ᶠ ≢ 1ᶠ
    +-assoc     : Associative _+_
    *-assoc     : Associative _*_
    +-comm      : Commutative _+_
    *-comm      : Commutative _*_
    0+-identity : LeftIdentity 0ᶠ _+_
    1*-identity : LeftIdentity 1ᶠ _*_
    0--inverse  : LeftInverse 0ᶠ 0-_ _+_
    ⁻¹-inverse  : ∀ {x} → x ≢ 0ᶠ → x ⁻¹ * x ≡ 1ᶠ
    *-+-distr   : _*_ DistributesOverˡ _+_

  0--right-inverse : RightInverse 0ᶠ 0-_ _+_
  0--right-inverse = +-comm ∙ 0--inverse

  ⁻¹-right-inverse  : ∀ {x} → x ≢ 0ᶠ → x * x ⁻¹ ≡ 1ᶠ
  ⁻¹-right-inverse p = *-comm ∙ ⁻¹-inverse p

  +0-identity : RightIdentity 0ᶠ _+_
  +0-identity = +-comm ∙ 0+-identity

  *1-identity : RightIdentity 1ᶠ _*_
  *1-identity = *-comm ∙ 1*-identity

  += : ∀ {x x' y y'} → x ≡ x' → y ≡ y' → x + y ≡ x' + y'
  += {x} {y' = y'} p q = ap (_+_ x) q ∙ ap (λ z → z + y') p

  *= : ∀ {x x' y y'} → x ≡ x' → y ≡ y' → x * y ≡ x' * y'
  *= {x} {y' = y'} p q = ap (_*_ x) q ∙ ap (λ z → z * y') p

  0-= : ∀ {x x'} → x ≡ x' → 0- x ≡ 0- x'
  0-= = ap 0-_

  -- Correct naming scheme?
  +-*-distr : _*_ DistributesOverʳ _+_
  +-*-distr = *-comm ∙ *-+-distr ∙ += *-comm *-comm

  0-c+c+x : ∀ {c x} → 0- c + c + x ≡ x
  0-c+c+x = += 0--inverse refl ∙ 0+-identity

  +-left-cancel : LeftCancel _+_
  +-left-cancel p = ! 0-c+c+x ∙ +-assoc
                  ∙ ap (λ z → 0- _ + z) p
                  ∙ ! +-assoc ∙ 0-c+c+x

  +-right-cancel : RightCancel _+_
  +-right-cancel p = +-left-cancel (+-comm ∙ p ∙ +-comm)

  *0-zero : RightZero 0ᶠ _*_
  *0-zero = +-right-cancel  (+= refl (! *1-identity) ∙ ! *-+-distr
                            ∙ *= refl 0+-identity ∙ *1-identity ∙ ! 0+-identity)

  0*-zero : LeftZero 0ᶠ _*_
  0*-zero = *-comm ∙ *0-zero

  -- name ?
  *-0- : ∀ {x y} → 0- (x * y) ≡ (0- x) * y
  *-0- = +-right-cancel (0--inverse ∙ ! 0*-zero ∙ *= (! 0--inverse) refl ∙ +-*-distr)

  -1*-neg : ∀ {x} → -1ᶠ * x ≡ 0- x
  -1*-neg = ! *-0- ∙ 0-= 1*-identity

  0--involutive : Involutive 0-_
  0--involutive = +-left-cancel (0--right-inverse ∙ ! 0--inverse)

  -0≡0 : -0ᶠ ≡ 0ᶠ
  -0≡0 = +-left-cancel (0--right-inverse ∙ ! 0+-identity)

  noZeroDivisor : ∀ {x y} → x ≢ 0ᶠ → y ≢ 0ᶠ → x * y ≢ 0ᶠ
  noZeroDivisor nx ny x*y≡0ᶠ = ny (! *1-identity ∙ *= refl (! ⁻¹-inverse nx)
                                   ∙ *= refl *-comm ∙ ! *-assoc
                                   ∙ *= (*-comm ∙ x*y≡0ᶠ) refl ∙ 0*-zero
                                   )

  open Field-Ops field-ops public

record Field {ℓ} (A : Set ℓ) : Set ℓ where
  field
    field-ops    : Field-Ops A
    field-struct : Field-Struct field-ops
  open Field-Struct field-struct public

open import Reflection.NP
open import Data.List
open import Data.Maybe.NP

module TermField {a} {A : Set a} (F : Field A) where
  open Field F
  pattern _`+_ t u = con (quote _+_) (argᵛʳ t ∷ argᵛʳ u ∷ [])
  pattern _`*_ t u = con (quote _*_) (argᵛʳ t ∷ argᵛʳ u ∷ [])
  pattern `0-_ t = conᵛʳ (quote 0-_) t
  pattern _`⁻¹ t = conᵛʳ (quote _⁻¹) t
  pattern `0ᶠ = con (quote 0ᶠ) []
  pattern `1ᶠ = con (quote 1ᶠ) []

  module Decode-RawField {b}{B : Set b}(G : Field-Ops B)(default : Decode-Term B) where
    module G = Field-Ops G
    decode-Field : Decode-Term B
    decode-Field `0ᶠ = just G.0ᶠ
    decode-Field `1ᶠ = just G.1ᶠ
    decode-Field (t `⁻¹) = map? G._⁻¹ (decode-Field t)
    decode-Field (`0- t) = map? G.0-_ (decode-Field t)
    decode-Field (t `+ u) = ⟪ G._+_ · decode-Field t · decode-Field u ⟫?
    decode-Field (t `* u) = ⟪ G._*_ · decode-Field t · decode-Field u ⟫?
    decode-Field t = default t

open ≡-Reasoning
open import Data.List

infixl 6 _+'_
infixl 7 _*'_
data Tm (A : Set) : Set where
  lit       : (n : ℤ) → Tm A
  var       : (x : A) → Tm A
  _+'_ _*'_ : Tm A → Tm A → Tm A

pattern  0' = lit (ℤ.+ 0)
pattern  1' = lit (ℤ.+ 1)
pattern  2' = lit (ℤ.+ 1)
pattern  3' = lit (ℤ.+ 1)
pattern -1' = lit ℤ.-[1+ 0 ]
pattern -2' = lit ℤ.-[1+ 1 ]
pattern -3' = lit ℤ.-[1+ 2 ]

record Var (A : Set) : Set where
  constructor _^'_
  field
    v : A
    e : ℤ

data Nf' (A : Set) : Set where
  _*'_ : (n : ℤ) (vs : List (Var A)) → Nf' A

data Nf (A : Set) : Set where
  _+'_ : (n : ℤ) (ts' : List (Nf' A)) → Nf A

module _ {A : Set} where
    infixl 6 _+ᴺ_

    litᴺ : ℤ → Nf A
    litᴺ n = n +' []

    varᴺ : (x : A) → Nf A
    varᴺ x = ℤ.+ 0 +' (ℤ.+ 1 *' (x ^' (ℤ.+ 1) ∷ []) ∷ [])

    _+ᴺ_ : Nf A → Nf A → Nf A
    (n +' ts) +ᴺ (m +' us) = n ℤ.+ m +' (ts ++ us)

    infixl 7 _**_ _***_ _*ᴺ_
    _**_ : ℤ → List (Nf' A) → Nf A
    z ** [] = z +' []
    m ** (n *' vs ∷ ts) with m ** ts
    ... | z +' us = z +' ((m ℤ.* n) *' vs ∷ us)

    _***_ : List (Nf' A) → List (Nf' A) → Nf A
    ts *** us = ℤ.+ 0 +' (ts ++ us)

    _*ᴺ_ : Nf A → Nf A → Nf A
    (n +' ts) *ᴺ (m +' us) =
       n ℤ.* m +' [] +ᴺ n ** us +ᴺ m ** ts +ᴺ ts *** us

module Normalizer {F : Set}
                  (F-field : Field F) where
    open Field F-field renaming (0-_ to -_)

    module _ {A : Set} where
        eval : (A → F) → Tm A → F
        eval ρ (lit x) = ℤ[ x ]
        eval ρ (t +' t₁) = eval ρ t + eval ρ t₁
        eval ρ (t *' t₁) = eval ρ t * eval ρ t₁
        eval ρ (var x)  = ρ x

        norm™ : Tm A → Nf A
        norm™ (lit x) = litᴺ x
        norm™ (var x) = varᴺ x
        norm™ (t +' t₁) = norm™ t +ᴺ norm™ t₁
        norm™ (t *' t₁) = norm™ t *ᴺ norm™ t₁

        _+''_ : Tm A → Tm A → Tm A
        -- lit (ℤ.+ 0) +'' u = u
        t +'' lit (ℤ.+ 0) = t
        t +'' u = t +' u

        _*''_ : Tm A → Tm A → Tm A
        -- lit (ℤ.+ 0) *'' u = lit (ℤ.+ 0)
        -- lit (ℤ.-[1+_] 0) *'' u = lit (ℤ.+ 0)
        t *'' lit (ℤ.+ 0) = lit (ℤ.+ 0)
        t *'' lit (ℤ.-[1+_] 0) = lit (ℤ.+ 0)
        -- lit (ℤ.+ 1) *'' u = u
        t *'' lit (ℤ.+ 1) = t
        t *'' u           = t *' u

        reifyVar : Var A → Tm A
        reifyVar (v ^' (ℤ.+ n))    = fold (lit (ℤ.+ 1)) (λ x → var v *'' x) n
        reifyVar (v ^' ℤ.-[1+ n ]) = fold (lit (ℤ.-[1+_] 1)) (λ x → var v *'' x) n

        reifyNf' : Nf' A → Tm A
        reifyNf' (n *' vs) = foldr (λ v t → reifyVar v *'' t) (lit n) vs

        reifyNf : Nf A → Tm A
        reifyNf (n +' ts') = foldr (λ n t → reifyNf' n +'' t) (lit n) ts'

        module _ ρ where
            _∼_ : (t u : Tm A) → Set
            t ∼ u = eval ρ t ≡ eval ρ u

            +'∼+'' : ∀ t u → (t +' u) ∼ (t +'' u)
            +'∼+'' t (lit (ℤ.+ zero)) = +0-identity
            +'∼+'' t (lit (ℤ.+ (suc x))) = refl
            +'∼+'' t (lit ℤ.-[1+ x ]) = refl
            +'∼+'' t (var x) = refl
            +'∼+'' t (u +' u₁) = refl
            +'∼+'' t (u *' u₁) = refl

            {-
            +-reifyNf : ∀ t u → reifyNf (t +ᴺ u) ∼ (reifyNf t +' reifyNf u)
            +-reifyNf (n +' ts') (n₁ +' ts'') = {!!}

            *-reifyNf : ∀ t u → reifyNf (t *ᴺ u) ∼ (reifyNf t *' reifyNf u)
            *-reifyNf t u = {!!}

            pf : ∀ t → eval ρ (reifyNf (norm™ t)) ≡ eval ρ t
            pf (lit n) = refl
            pf (var x) = refl
            pf (t +' t₁) rewrite +-reifyNf (norm™ t) (norm™ t₁) | pf t | pf t₁ = refl
            pf (t *' t₁) rewrite *-reifyNf (norm™ t) (norm™ t₁) | pf t | pf t₁ = refl
            -}
-- -}
-- -}
-- -}
-- -}
-- -}

Add more derived Field properties

Add more derived Field properties


data Bool : Set where
  true  : Bool
  false : Bool

_∨_ : Bool → Bool → Bool
true ∨ _  = true
false ∨ b = b

_∧_ : Bool → Bool → Bool
false ∧ _ = false
true ∧ b  = b

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

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

_==_ : ℕ → ℕ → Bool
zero == zero   = true
suc n == suc m = n == m
_ == _         = false

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

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

[_] : {A : Set} → A → List A
[ x ] = x ∷ []

any : {A : Set} → (A → Bool) → List A → Bool
any _ []       = false
any f (x ∷ xs) = (f x) ∨ (any f xs)

_∈_ : ℕ → List ℕ → Bool
x ∈ []       = false
x ∈ (y ∷ ys) with x == y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q == s
(p ⇒ q) ≡≡ (r ⇒ s) = (p == r) ∧ (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ []       = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List ℕ → List ℕ
closure [] found               = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) ∨ (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs [])
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs ([ n ]))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) ∧ (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ [] ⟫ arr     = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) ∨ (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown

proofs : List Arrow
proofs =
   (3 ⇒ (⇒ 4)) ∷
--   (5 ⇒ (⇒ 4)) ∷
   (6 ⇒ (⇒ 4)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (5 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (6 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (5 ⇒ (⇒ 10)) ∷
   (10 ⇒ (⇒ 4)) ∷
   (5 ⇒ (⇒ 11)) ∷
   (6 ⇒ (⇒ 11)) ∷
   (11 ⇒ (⇒ 4)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (8 ⇒ (⇒ 4)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 8)) ∷
   (3 ⇒ (⇒ 8)) ∷
   (5 ⇒ (3 ⇒ (⇒ 9))) ∷
   (6 ⇒ (7 ⇒ (⇒ 10))) ∷
   (6 ⇒ (3 ⇒ (⇒ 3))) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (8 ⇒ (⇒ 10))) ∷
   (3 ⇒ (10 ⇒ (⇒ 9))) ∷
   (5 ⇒ (⇒ 1)) ∷
   (3 ⇒ (1 ⇒ (⇒ 9))) ∷
   (1 ⇒ (⇒ 2)) ∷
   (10 ⇒ (⇒ 2)) ∷ []

cms : List Separation
cms =
  (model (12 ∷ 6 ∷ 11 ∷ 4 ∷ 1 ∷ []) (5 ∷ 3 ∷ 7 ∷ 7 ∷ [])) ∷
  (model (6 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ []) (5 ∷ [])) ∷
  (model (12 ∷ 5 ∷ 11 ∷ 4 ∷ 1 ∷ []) (6 ∷ 3 ∷ [])) ∷
  (model (5 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ []) (6 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 11 ∷ []) (5 ∷ 6 ∷ 3 ∷ 8 ∷ 9 ∷ 1 ∷ [])) ∷
  (model (12 ∷ 5 ∷ 6 ∷ 4 ∷ 11 ∷ 1 ∷ []) (3 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 11 ∷ 7 ∷ []) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 8 ∷ 1 ∷ [])) ∷
  (model (10 ∷ 9 ∷ []) (1 ∷ [])) ∷
  (model (3 ∷ 4 ∷ 11 ∷ []) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 7 ∷ 1 ∷ [])) ∷
  (model (12 ∷ 7 ∷ 1 ∷ []) (4 ∷ 11 ∷ 8 ∷ [])) ∷
  (model (9 ∷ 3 ∷ 10 ∷ 8 ∷ 1 ∷ []) (11 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 10 ∷ 1 ∷ []) (11 ∷ 3 ∷ [])) ∷
  (model (3 ∷ 6 ∷ 5 ∷ []) ([])) ∷
  (model (1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ []) (12 ∷ [])) ∷ []

testp : Arrow
testp = (5 ⇒ (⇒ 10))

testd : Arrow
testd = (5 ⇒ (⇒ 4))

tests : Arrow
tests = (5 ⇒ (⇒ 3))

testu : Arrow
testu = (6 ⇒ (⇒ 1))

data Bool : Set where
  true  : Bool
  false : Bool

_∨_ : Bool → Bool → Bool
true ∨ _  = true
false ∨ b = b

_∧_ : Bool → Bool → Bool
false ∧ _ = false
true ∧ b  = b

if_then_else_ : {A : Set} → Bool → A → A → A
if true  then a else _ = a
if false then _ else b = b

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

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

_==_ : ℕ → ℕ → Bool
zero == zero   = true
suc n == suc m = n == m
_ == _         = false

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

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

[_] : {A : Set} → A → List A
[ x ] = x ∷ []

any : {A : Set} → (A → Bool) → List A → Bool
any _ []       = false
any f (x ∷ xs) = (f x) ∨ (any f xs)

_∈_ : ℕ → List ℕ → Bool
x ∈ []       = false
x ∈ (y ∷ ys) with x == y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q == s
(p ⇒ q) ≡≡ (r ⇒ s) = (p == r) ∧ (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ []       = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List ℕ → List ℕ
closure [] found               = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) ∨ (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs [])
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs ([ n ]))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) ∧ (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ [] ⟫ arr     = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) ∨ (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown

proofs : List Arrow
proofs =
   (3 ⇒ (⇒ 4)) ∷
--   (5 ⇒ (⇒ 4)) ∷
   (6 ⇒ (⇒ 4)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (5 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (6 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (5 ⇒ (⇒ 10)) ∷
   (10 ⇒ (⇒ 4)) ∷
   (5 ⇒ (⇒ 11)) ∷
   (6 ⇒ (⇒ 11)) ∷
   (11 ⇒ (⇒ 4)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (8 ⇒ (⇒ 4)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 8)) ∷
   (3 ⇒ (⇒ 8)) ∷
   (5 ⇒ (3 ⇒ (⇒ 9))) ∷
   (6 ⇒ (7 ⇒ (⇒ 10))) ∷
   (6 ⇒ (3 ⇒ (⇒ 3))) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (8 ⇒ (⇒ 10))) ∷
   (3 ⇒ (10 ⇒ (⇒ 9))) ∷
   (5 ⇒ (⇒ 1)) ∷
   (3 ⇒ (1 ⇒ (⇒ 9))) ∷
   (1 ⇒ (⇒ 2)) ∷
   (10 ⇒ (⇒ 2)) ∷ []

cms : List Separation
cms =
  (model (12 ∷ 6 ∷ 11 ∷ 4 ∷ 1 ∷ []) (5 ∷ 3 ∷ 7 ∷ 7 ∷ [])) ∷
  (model (6 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ []) (5 ∷ [])) ∷
  (model (12 ∷ 5 ∷ 11 ∷ 4 ∷ 1 ∷ []) (6 ∷ 3 ∷ [])) ∷
  (model (5 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ []) (6 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 11 ∷ []) (5 ∷ 6 ∷ 3 ∷ 8 ∷ 9 ∷ 1 ∷ [])) ∷
  (model (12 ∷ 5 ∷ 6 ∷ 4 ∷ 11 ∷ 1 ∷ []) (3 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 11 ∷ 7 ∷ []) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 8 ∷ 1 ∷ [])) ∷
  (model (10 ∷ 9 ∷ []) (1 ∷ [])) ∷
  (model (3 ∷ 4 ∷ 11 ∷ []) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 7 ∷ 1 ∷ [])) ∷
  (model (12 ∷ 7 ∷ 1 ∷ []) (4 ∷ 11 ∷ 8 ∷ [])) ∷
  (model (9 ∷ 3 ∷ 10 ∷ 8 ∷ 1 ∷ []) (11 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 10 ∷ 1 ∷ []) (11 ∷ 3 ∷ [])) ∷
  (model (3 ∷ 6 ∷ 5 ∷ []) ([])) ∷
  (model (1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ []) (12 ∷ [])) ∷ []

testp : Relation
testp = consider proofs cms (5 ⇒ (⇒ 10))

testd : Relation
testd = consider proofs cms (5 ⇒ (⇒ 4))

tests : Relation
tests = consider proofs cms (5 ⇒ (⇒ 3))

testu : Relation
testu = consider proofs cms (6 ⇒ (⇒ 1))

testcl : List ℕ
testcl = closure proofs (5 ∷ [])

Add tests

Add tests