Added draft: Non-terminating version of the GCD.

Ignore-this: bd7f27c02daff7cbc875dcd3a08191f4

darcs-hash:20110324170647-3bd4e-44433eb9e26bf92661aac951099b570218ac7f9b.gz

------------------------------------------------------------------------------
module GCD where

open import Data.Nat
open import Relation.Nullary

gcd : ℕ → ℕ → ℕ
gcd 0       0       = 0
gcd (suc m) 0       = suc m
gcd 0       (suc n) = suc n
gcd (suc m) (suc n) with (suc m ≤? suc n)
gcd (suc m) (suc n) | yes p = gcd (suc m) (suc n ∸ suc m)
gcd (suc m) (suc n) | no ¬p = gcd (suc m ∸ suc n) (suc n)

error: pathspec 'Draft/FOTC/Program/GCD/GCD.agda' did not match any file(s) known to git


Added Everything.

Added Everything.

Ignore-this: ea7f485a93e2d8c0701a88a1f3cf6b0b

darcs-hash:20110220154508-3bd4e-207ea1b168d00935008b1197f4208c2b14c0d47d.gz

------------------------------------------------------------------------------
-- All the mirror function modules
------------------------------------------------------------------------------

module Draft.Mirror.Everything where

open import Draft.Mirror.ListTree.Closures
open import Draft.Mirror.ListTree.PropertiesATP
open import Draft.Mirror.ListTree.PropertiesI
open import Draft.Mirror.Mirror.ConsistencyTest
open import Draft.Mirror.Mirror
open import Draft.Mirror.PropertiesATP
open import Draft.Mirror.PropertiesI
open import Draft.Mirror.Tree.Closures

error: pathspec 'Draft/Mirror/Everything.agda' did not match any file(s) known to git


{-# OPTIONS --without-K #-}
open import Type
open import Level.NP
open import Data.One using (𝟙)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; refl)
open import Function.Extensionality
open import HoTT
open Equivalences

module Control.Protocol.End where

record End_ ℓ : ★_ ℓ where
  constructor end

End : ∀ {ℓ} → ★_ ℓ
End = End_ _

End-equiv : End ≃ 𝟙
End-equiv = equiv {₀} _ _ (λ _ → refl) (λ _ → refl)

End-uniq : {{_ : UA}} → End ≡ 𝟙
End-uniq = ua End-equiv

error: pathspec 'Control/Protocol/End.agda' did not match any file(s) known to git


Model: label for indexed descriptions

Model: label for indexed descriptions

{-# OPTIONS --type-in-type #-}

-- Yeah, that's type-in-type. I'm a sissy, I want to use the stdlib, I
-- don't want to reimplement ℕ, ⊤, etc. in Set1.

module ILabel where

open import Data.String

open import Data.Empty
open import Data.Unit

open import Data.Product

open import Data.Maybe
open import Data.Nat

open import Relation.Binary.PropositionalEquality

--****************************************************************
-- A universe of labels
--****************************************************************

infixr 5 _∷_

data AllowedBy : Set -> Set where
  ε    : forall {T} ->
         AllowedBy T
  _∷_  : {S : Set}{T : S -> Set} ->
         (s : S)(ts : AllowedBy (T s)) -> AllowedBy ((x : S) -> T x)

UId = String

-- The universe (that's a tiny one):

data Label : Set where
  label : (u : UId)(T : Set)(ts : AllowedBy T) -> Label

--****************************************************************
-- IDesc & co.
--****************************************************************

data IDesc (I : Set1) : Set1 where
  var    : I -> IDesc I
  const  : Set -> IDesc I
  prod   : IDesc I -> IDesc I -> IDesc I
  sigma  : (S : Set) -> (S -> IDesc I) -> IDesc I
  pi     : (S : Set) -> (S -> IDesc I) -> IDesc I

desc : {I : Set1} -> IDesc I -> (I -> Set) -> Set
desc (var i) P = P i
desc (const X) P = X
desc (prod D D') P = desc D P × desc D' P
desc (sigma S T) P = Σ S (\s -> desc (T s) P)
desc (pi S T) P = (s : S) -> desc (T s) P

-- We (may) stuck a label on the fix-point:

data IMu {I : Set1}(L : Maybe (I -> Label))(R : I -> IDesc I)(i : I) : Set where
  con : desc (R i) (\j -> IMu L R j) -> IMu L R i

--****************************************************************
-- Example: Nat
--****************************************************************

data NatConst : Set where
  Ze : NatConst
  Su : NatConst

natCases : NatConst -> IDesc ⊤
natCases Ze = const ⊤
natCases Suc = var _

NatD : ⊤ → IDesc ⊤
NatD _ = sigma NatConst natCases

Nat : Set
Nat = IMu (just (\ _ -> label "Nat" Set ε)) NatD _

--****************************************************************
-- Example: Vector
--****************************************************************

data VecConst : ℕ -> Set where
  Vnil : VecConst 0
  Vcons : {n : ℕ} -> VecConst (1 + n)

vecDChoice : Set -> (n : ℕ) -> VecConst n -> IDesc ℕ
vecDChoice X 0 Vnil = const ⊤
vecDChoice X (suc n) Vcons = prod (const X) (var n)

vecD : Set -> ℕ -> IDesc ℕ
vecD X n = sigma (VecConst n) (vecDChoice X n)

vec : Set -> ℕ -> Set
vec X n = IMu (just (\n -> label "Vec" (ℕ -> Set) (n ∷ ε))) (vecD X) n

--****************
-- Example: Fin
--****************

data FinConst : ℕ -> Set where
  Fz : {n : ℕ} -> FinConst (1 + n)
  Fs : {n : ℕ} -> FinConst (1 + n)

finDChoice : (n : ℕ) -> FinConst n -> IDesc ℕ
finDChoice 0 ()
finDChoice (suc n) Fz = const ⊤
finDChoice (suc n) Fs = var n

finD : ℕ -> IDesc ℕ
finD n = sigma (FinConst n) (finDChoice n)

fin : ℕ -> Set
fin n = IMu (just (\ n -> label "Fin" (ℕ -> Set) (n ∷ ε))) finD n

--****************
-- Example: Identity type
--****************

-- data Id (A : Set) (a : A) : A -> Set := (refl : Id A a a)

data IdConst : Set where
  Refl : IdConst

idD : (A : Set)(a : A)(b : A) -> IDesc A
idD A a b = sigma IdConst (\ _ -> const (a ≡ b))

id : (A : Set)(a : A)(b : A) -> Set
id A a b = IMu (just (\ b -> label "Id" ((A : Set)(a : A)(b : A) -> Set) (A ∷ a ∷ b ∷ ε))) (idD A a) b

error: pathspec 'models/ILabel.agda' did not match any file(s) known to git


Added a simple solver for equations involving max and plus.

module Add-Max-Solver where

import Algebra

open import Data.Bool using (Bool ; true ; false)
open import Data.Nat.NP
import Data.Nat.Properties as Props
open import Data.Fin using (Fin ; Ordering ; less ; equal ; greater)
open import Data.List
open import Data.Vec hiding ([_] ; _++_)

open import Relation.Binary.PropositionalEquality hiding ([_])

open import Relation.Nullary using (Dec ; yes ; no)

module ℕP = Algebra.CommutativeSemiring Props.commutativeSemiring
module ℕ⊔ = Algebra.CommutativeSemiringWithoutOne Props.⊔-⊓-0-commutativeSemiringWithoutOne

+-distr-⊔ : ∀ a m n → a + (m ⊔ n) ≡ (a + m) ⊔ (a + n)
+-distr-⊔ zero m n = refl
+-distr-⊔ (suc a) m n = cong suc (+-distr-⊔ a m n)

+-distr-⊔' : ∀ m n a → (m ⊔ n) + a ≡ (m + a) ⊔ (n + a)
+-distr-⊔' m n a = trans (ℕP.+-comm (m ⊔ n) a) (trans (+-distr-⊔ a m n)
               (cong₂ _⊔_ (ℕP.+-comm a m) (ℕP.+-comm a n)))

module NatSyntax (nrVars : ℕ)(G : Vec ℕ nrVars) where

  Env = Vec ℕ nrVars
  Var = Fin nrVars

  data Syn : Set where
    con : ℕ → Syn
    var : Var → Syn
    _:+_ : Syn → Syn → Syn
    _:u_ : Syn → Syn → Syn

  infixl 4 _:+_

  eval : Syn → ℕ
  eval (con x) = x
  eval (var x) = lookup x G
  eval (syn :+ syn₁) = eval syn + eval syn₁
  eval (syn :u syn₁) = eval syn ⊔ eval syn₁

  data N1 : Syn → Set where
    con_::[] : ∀ x → N1 (con x)
    var_::_ : ∀ {S} (i : Var) → N1 S → N1 (var i :+ S)

  data N2 : Syn → Set where
    lift : ∀ {S} → N1 S → N2 S
    max  : ∀ {S S'} → N1 S → N2 S' → N2 (S :u S')

  record N1Proof S : Set where
    constructor _⊢_
    field
      {S'} : Syn
      term : N1 S'
      proof : eval S ≡ eval S'

  record N2Proof S : Set where
    constructor _⊢_
    field
      {S'} : Syn
      term : N2 S'
      proof : eval S ≡ eval S'

  liftP : ∀ {S} → N1Proof S → N2Proof S
  liftP (term ⊢ proof) = (lift term) ⊢ proof

  incr : ∀ {S'} S → N1 S' → N1Proof (S :+ S')
  incr S con x ::[] = con eval S + x ::[] ⊢ refl
  incr {var .i :+ S'} S (var i :: s1) with incr S s1
  ... | s1' ⊢ p = (var i :: s1') ⊢ trans (sym (ℕP.+-assoc (eval S) (lookup i G) (eval S')))
                                   (trans(cong₂ _+_ (ℕP.+-comm (eval S) (lookup i G)) (refl {x = eval S'}))
                                   (trans (ℕP.+-assoc (lookup i G) (eval S) (eval S'))
                                   (cong (_+_ (lookup i G)) p)))

  append : ∀ {S S'} → N1 S → N1 S' → N1Proof (S :+ S')
  append con x ::[] s2 = incr _ s2
  append (var i :: s1) s2 with append s1 s2
  ... |  s3 ⊢ proof = var i :: s3 ⊢ trans (ℕP.+-assoc (lookup i G) _ _) (cong (_+_ (lookup i G)) proof)

  insert : ∀ {S} i → N1 S → N1Proof (var i :+ S)
  insert i con x ::[] = (var i :: con x ::[]) ⊢ refl
  insert {var .j :+ S} i (var j :: s1) with Data.Fin.toℕ i ≤? Data.Fin.toℕ j
  ... | yes _ = var i :: var j :: s1 ⊢ refl
  ... | no  _ with insert i s1
  ... | t ⊢ proof = var j :: t ⊢ trans (sym (ℕP.+-assoc (lookup i G) (lookup j G) (eval S)))
                                       (trans
                                          (cong₂ _+_ (ℕP.+-comm (lookup i G) (lookup j G))
                                           (refl {x = eval S}))
                                       (trans (ℕP.+-assoc (lookup j G) _ _) (cong (_+_ (lookup j G)) proof)))

  merge : ∀ {S S'} → N1 S → N1 S' → N1Proof (S :+ S')
  merge con x ::[] s2 = incr _ s2
  merge (var i :: s1) s2 with merge s1 s2
  ... | t1 ⊢ p1 with insert i t1
  ... | t2 ⊢ p2 = t2 ⊢ trans (trans (ℕP.+-assoc (lookup i G) _ _) (cong (_+_ (lookup i G)) p1)) p2

  mapN1-N2 : ∀ {S S'} → N1 S → N2 S' → N2Proof (S :+ S')
  mapN1-N2 s1 (lift x) = liftP (merge s1 x)
  mapN1-N2 {S} s1 (max x s2) with merge s1 x | mapN1-N2 s1 s2
  ... | t1 ⊢ p1 | t2 ⊢ p2 = (max t1 t2) ⊢ trans (+-distr-⊔ (eval S) _ _) (cong₂ _⊔_ p1 p2)

  u-merge : ∀ {S S'} → N2 S → N2 S' → N2Proof (S :u S')
  u-merge (lift x)   s2 = max x s2 ⊢ refl
  u-merge {S :u S'} (max x s1) s2 with u-merge s1 s2
  ... | t ⊢ p = (max x t) ⊢ trans (ℕ⊔.+-assoc (eval S) _ _) (cong (_⊔_ (eval S)) p)

  +-merge : ∀ {S S'} → N2 S → N2 S' → N2Proof (S :+ S')
  +-merge (lift x)   s2 = mapN1-N2 x s2
  +-merge {S :u S'} (max x s1) s2 with mapN1-N2 x s2 |  +-merge s1 s2
  ... | tx ⊢ px | ts ⊢ ps with u-merge tx ts
  ... | t ⊢ p = t ⊢ trans (trans (+-distr-⊔' (eval S) _ _) (cong₂ _⊔_ px ps)) p

  _≤ℕ_ : ℕ → ℕ → Bool
  m ≤ℕ n with m ≤? n
  ... | yes _ = true
  ... | no  _ = false

  _≤1_ : ∀ {S S'} → N1 S → N1 S' → Bool
  con x ::[] ≤1 con x₁ ::[] = x ≤ℕ x₁
  con x ::[] ≤1 (var i :: ys) = true
  (var i :: xs) ≤1 con x ::[] = false
  (var i :: xs) ≤1 (var j :: ys) with Data.Fin.compare i j
  (var .(Data.Fin.inject least) :: xs) ≤1 (var j :: ys) | less .j least = true
  (var .j :: xs) ≤1 (var j :: ys) | equal .j = xs ≤1 ys
  (var i :: xs) ≤1 (var .(Data.Fin.inject least) :: ys) | greater .i least = false

  N2-insert : ∀ {S S'} → N1 S → N2 S' → N2Proof (S :u S')
  N2-insert {S} x (lift x₁) with x ≤1 x₁
  ... | true = max x (lift x₁) ⊢ refl
  ... | false = max x₁ (lift x) ⊢ ℕ⊔.+-comm (eval S) _
  N2-insert {S} {S' :u S''} x (max x₁ s) with x ≤1 x₁
  ... | true  = (max x (max x₁ s)) ⊢ refl
  ... | false with N2-insert x s
  ... | t ⊢ p = (max x₁ t) ⊢ trans (trans (sym (ℕ⊔.+-assoc (eval S) (eval S') (eval S'')))
                                      (trans (cong₂ _⊔_ (ℕ⊔.+-comm (eval S) _) (refl {x = eval S''}))
                                       (ℕ⊔.+-assoc (eval S') _ _))) (cong (_⊔_ (eval S')) p)

  sort : ∀ {S} → N2 S → N2Proof S
  sort (lift x) = lift x ⊢ refl
  sort {S :u S'} (max x s1) with sort s1
  ... | s2 ⊢ p2 with N2-insert x s2
  ... | s3 ⊢ p3 = s3 ⊢ (trans (cong (_⊔_ (eval S)) p2) p3)

  norm2 : (x : Syn) → N2Proof x
  norm2 (con x) = (lift con x ::[]) ⊢ refl
  norm2 (var x) = lift (var x :: con 0 ::[]) ⊢ ℕP.+-comm 0 (lookup x G)
  norm2 (x :+ x₁) with norm2 x | norm2 x₁
  ... | s1 ⊢ p1 | s2 ⊢ p2 with +-merge s1 s2
  ... | s3 ⊢ p3 = s3 ⊢ (trans (cong₂ _+_ p1 p2) p3)
  norm2 (x :u x₁) with norm2 x | norm2 x₁
  ... | s1 ⊢ p1 | s2 ⊢ p2 with u-merge s1 s2
  ... | s3 ⊢ p3 = s3 ⊢ trans (cong₂ _⊔_ p1 p2) p3

  norm : (x : Syn) → N2Proof x
  norm x with norm2 x
  ... | t1 ⊢ p1 with sort t1
  ... | t2 ⊢ p2 = t2 ⊢ trans p1 p2

  proof : (x y : Syn) → eval (N2Proof.S' (norm x)) ≡ eval (N2Proof.S' (norm y))
            → eval x ≡ eval y
  proof x y eq = trans (N2Proof.proof (norm x)) (trans eq (sym (N2Proof.proof (norm y))))

test : ∀ (x y : ℕ) → 5 + x + (9 + y + 10) ≡ 12 + y + x + 12
test x y = proof (con 5 :+ x' :+ (con 9 :+ y' :+ con 10)) (con 12 :+ y' :+ x' :+ con 12) refl where
  open NatSyntax 2 (x ∷ y ∷ [])
  x' = var Data.Fin.zero
  y' = var (Data.Fin.suc Data.Fin.zero)

test' : ∀ (x y : ℕ) → ((x + 3) ⊔ (2 + y)) + 7 ≡ (2 + y + 7) ⊔ (5 + x + 5)
test' x y = proof LHS RHS refl where
  open NatSyntax 2 (x ∷ y ∷ [])
  #_ = con
  x' = var Data.Fin.zero
  y' = var (Data.Fin.suc Data.Fin.zero)
  LHS = ((x' :+ # 3) :u (# 2 :+ y')) :+ # 7
  RHS = (# 2 :+ y' :+ # 7) :u (# 5 :+ x' :+ # 5)

error: pathspec 'Add-Max-Solver.agda' did not match any file(s) known to git


First go at a clean model of IDesc. With too much universe polymorphism for now.

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i : Level}(A B : Set i) -> Set i
A * B = Sigma A \_ -> B

fst : {i : Level}{A : Set i}{B : A -> Set i} -> Sigma A B -> A
fst (a , _) = a

snd : {i : Level}{A : Set i}{B : A -> Set i} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
record One  {i : Level} : Set i where

--****************
-- Sum and friends
--****************

data _+_ {i : Level}(A B : Set i) : Set i where
  l : A -> A + B
  r : B -> A + B

--********************************************
-- Desc code
--********************************************

data IDesc {i : Level}(I : Set i) : Set (suc i) where
  var : I -> IDesc I
  const : Set i -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set i) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set i) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : {i : Level}(I : Set i) -> IDesc I -> (I -> Set i) -> Set i
desc I (var i) P = P i
desc I (const X) P = X
desc I (prod D D') P = desc I D P * desc I D' P
desc I (sigma S T) P = Sigma S (\s -> desc I (T s) P)
desc I (pi S T) P = (s : S) -> desc I (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {i : Level}(I : Set i)(R : I -> IDesc I) : IDesc I -> Set (suc i) where
  rec : (i : I) -> IMu I R (R i) -> IMu I R (var i)
  lambda : (S : Set i)(D : S -> IDesc I) -> ((s : S) -> IMu I R (D s)) -> IMu I R (pi S D)
  pair : (S : Set i)(D : S -> IDesc I) -> (Sigma S (\s -> IMu I R (D s))) -> IMu I R (sigma S D)

error: pathspec 'models/IDesc.agda' did not match any file(s) known to git


module Relation.Nullary.NP where

open import Type
open import Data.Sum
open import Relation.Nullary public

module _ {a b} {A : ★_ a} {B : ★_ b} where
    Dec-⊎ : Dec A → Dec B → Dec (A ⊎ B)
    Dec-⊎ (yes p) _       = yes (inj₁ p)
    Dec-⊎ (no ¬p) (yes p) = yes (inj₂ p)
    Dec-⊎ (no ¬p) (no ¬q) = no [ ¬p , ¬q ]

error: pathspec 'lib/Relation/Nullary/NP.agda' did not match any file(s) known to git


Added draft: Numerical proofs.

Added draft: Numerical proofs.

Ignore-this: 78616fa321c24ccfa77f80bbe1a5deac

darcs-hash:20110208154828-3bd4e-b37f7651ed156539f7454aa6c2966a328340e785.gz

module Draft.McCarthy91.Arithmetic where

open import LTC.Base

open import Draft.McCarthy91.Numbers
open import LTC.Data.Nat
open import LTC.Data.Nat.Inequalities

postulate
  1+1>1 : GT (one + one) one
{-# ATP prove 1+1>1 #-}

postulate
  10+90≡100 : ten + ninety ≡ one-hundred
{-# ATP prove 10+90≡100 #-}

postulate
  90+10≡100 : ninety + ten ≡ one-hundred
{-# ATP prove 90+10≡100 #-}

postulate
  100-10≡90 : one-hundred ∸ ten ≡ ninety
{-# ATP prove 100-10≡90 #-}

error: pathspec 'Draft/McCarthy91/Arithmetic.agda' did not match any file(s) known to git


Natural numbers using our own equality module

module Nat1 where

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

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

open import Equality
one   = succ zero
two   = succ one
three = succ two

0-is-id : ∀ (n : ℕ) → (n + zero) ≡ n
0-is-id zero     =
  begin
    (zero + zero) ≈ zero by definition
  ∎
0-is-id (succ y) =
  begin
    (succ y + zero) ≈ succ (y + zero) by definition
                    ≈ succ y          by cong succ (0-is-id y)
  ∎

+-assoc : ∀ (a b c : ℕ) → (a + b) + c ≡ a + (b + c)
+-assoc zero     b c     = definition
+-assoc (succ a) b c     =
  begin ((succ a + b) + c)
               ≈ succ (a + b)  + c   by definition
               ≈ succ ((a + b) + c)  by definition
               ≈ succ (a  + (b + c)) by cong succ (+-assoc a b c)
               ≈ succ a   + (b + c)  by definition
  ∎

error: pathspec 'agda/Nat1.agda' did not match any file(s) known to git


Add Nat.Primality.NP

Add Nat.Primality.NP

{-# OPTIONS --without-K #-}
module Data.Nat.Primality.NP where

open import Data.Nat.NP
open import Data.Nat.Properties
open import Data.Nat.Divisibility.NP
open import Data.Nat.Primality public
  hiding (prime?) -- was slow

open import Data.Fin.Dec
open import Relation.Unary
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Negation
open import Relation.Nullary

-- same code but imports the fast _∣?_
prime? : Decidable Prime
prime? 0             = no λ()
prime? 1             = no λ()
prime? (suc (suc n)) = all? λ _ → ¬? (_ ∣? _)

prime-≥2 : ∀ {n} → Prime n → n ≥ 2
prime-≥2 {0}    ()
prime-≥2 {1}    ()
prime-≥2 {2+ _} _ = s≤s (s≤s z≤n)

prime-≢0 : ∀ {n} → Prime n → n ≢ 0
prime-≢0 {0}    () _
prime-≢0 {1+ _} _  ()

prime-≢1 : ∀ {n} → Prime n → n ≢ 1
prime-≢1 {0}    () _
prime-≢1 {1}    () _
prime-≢1 {2+ _} _  ()

error: pathspec 'lib/Data/Nat/Primality/NP.agda' did not match any file(s) known to git


Model: label for indexed descriptions

Model: label for indexed descriptions


Nand.Properties: proving adequacy of the nand based operations automatically using exploration functions

open import Level.NP
open import Type
open import Data.Two
open import Data.Product
open import Function.NP
open import Relation.Binary
open import Relation.Nullary.Decidable
open import Relation.Binary.PropositionalEquality

open import Explore.Type
import Explore.Explorable
open import Explore.Universe

open import FunUniverse.Nand
open import FunUniverse.Agda

module FunUniverse.Nand.Properties where

module Test {B : ★} (_≟_ : Decidable {A = B} _≡_)
            (A : Ty)
            {f g : El A → B} where
  module _ {ℓ} where
    Aᵉ : Explore ℓ (El A)
    Aᵉ = exploreU A
    Aⁱ : ExploreInd ℓ Aᵉ
    Aⁱ = exploreU-ind A
  Aˡ : Lookup {₀} Aᵉ
  Aˡ = lookupU A

  Check! = Aᵉ _×_ λ x → ✓ ⌊ f x ≟ g x ⌋

  check! : {p✓ : Check!} → f ≗ g
  check! {p✓} x = toWitness (Aˡ p✓ x)

  {- Unused
  open Explore.Explorable.Explorable₀ Aⁱ
  test-∧ = big-∧ λ x → ⌊ f x ≟ g x ⌋
  -}

module Test22 where
  nand nand' : 𝟚 × 𝟚 → 𝟚

  nand  (x , y) = not (x ∧ y)
  nand' (x , y) = not x ∨ not y

  module N = FromNand funRewiring nand
  module T = Test Data.Two._≟_

  module UnOp where
    open T 𝟚′

    pf-not : N.not ≗ not
    pf-not = check!

  module BinOp where
    open T (𝟚′ ×′ 𝟚′)

    pf-nand : nand ≗ nand'
    pf-nand = check!

    pf-and : N.and ≗ uncurry _∧_
    pf-and = check!

    pf-or : N.or ≗ uncurry _∨_
    pf-or = check!

    pf-nor : N.nor ≗ (not ∘ uncurry _∨_)
    pf-nor = check!

    pf-xor : N.xor ≗ uncurry _xor_
    pf-xor = check!

    pf-xnor : N.xnor ≗ uncurry _==_
    pf-xnor = check!

  module TriOp where
    open T (𝟚′ ×′ (𝟚′ ×′ 𝟚′))

    fork : 𝟚 × 𝟚 × 𝟚 → 𝟚
    fork (c , eᵢ) = proj eᵢ c

    pf-fork : N.fork ≗ fork
    pf-fork = check!

error: pathspec 'FunUniverse/Nand/Properties.agda' did not match any file(s) known to git


Added a simple solver for the linear functions (those who don't duplicate)

This make it possible to get functions like (A x B) x C -> (B x A) x C
be derived.

module linear-solver where

open import Data.Nat as ℕ using (ℕ)
open import Data.Fin as F using (Fin)
import Data.Fin.Props as FP

module Syntax {a} (A : Set a)(_x_ : A → A → A)(T : A)
  (R' : A → A → Set)
  (id' : ∀ {A} → R' A A)
  (_∻'_ : ∀ {A B C} → R' A B → R' B C → R' A C)
  (<id,tt>' : ∀ {A} → R' (A x T) A)
  (<id,tt>⁻¹' : ∀ {A} → R' A (A x T))
  (<tt,id>' : ∀ {A} → R' (T x A) A)
  (<tt,id>⁻¹' : ∀ {A} → R' A (T x A))
  (⟨_×'_⟩   : ∀ {A B C D} → R' A C → R' B D → R' (A x B) (C x D))
  (first'    : ∀ {A B C} → R' A B → R' (A x C) (B x C))
  (second'   : ∀ {A B C} → R' B C → R' (A x B) (A x C))
  (assoc'   : ∀ {A B C} → R' (A x (B x C)) ((A x B) x C))
  (assoc⁻¹' : ∀ {A B C} → R' ((A x B) x C) (A x (B x C)))
  (swap'    : ∀ {A B}   → R' (A x B) (B x A))
  nrVars (!_ : Fin nrVars → A) where

  Var = Fin nrVars

  open import Relation.Nullary using (yes ; no)
  open import Relation.Nullary.Decidable

  data Syn : Set where
   var : Var → Syn
   tt  : Syn
   _,_ : Syn → Syn → Syn

  #_ : ∀ m {m<n : True (ℕ.suc m ℕ.≤? nrVars)} → Syn
  #_ m {p} = var (F.#_ m {nrVars} {p})

  eval : Syn → A
  eval (var x) = ! x
  eval tt = T
  eval (s , s₁) = eval s x eval s₁

  data R : Syn → Syn → Set where
    _∻''_ : ∀ {A B C} → R A B → R B C → R A C
    <id,tt> : ∀ {A} → R (A , tt) A
    <tt,id> : ∀ {A} → R (tt , A) A
    <tt,id>⁻¹ : ∀ {A} → R A (tt , A)
    <id,tt>⁻¹ : ∀ {A} → R A (A , tt)
    ⟨_×''_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
    assoc : ∀ {A B C} → R (A , (B , C)) ((A , B) , C)
    assoc⁻¹ : ∀ {A B C} → R ((A , B) , C) (A , (B , C))
    id : ∀ {A} → R A A
    swap : ∀ {A B} → R (A , B) (B , A)

  ⟨_×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
  ⟨ id × id ⟩ = id
  ⟨ r₁ × r₂ ⟩ = ⟨ r₁ ×'' r₂ ⟩

  _∻_ : ∀ {A B C} → R A B → R B C → R A C
  id ∻ r₂ = r₂
  r₁ ∻ id = r₁
  <tt,id>⁻¹ ∻ <tt,id> = id
  <id,tt>⁻¹ ∻ <id,tt> = id
  <tt,id> ∻ <tt,id>⁻¹ = id
  <id,tt> ∻ <id,tt>⁻¹ = id
  swap ∻ <id,tt> = <tt,id>
  swap ∻ <tt,id> = <id,tt>
  <id,tt>⁻¹ ∻ swap = <tt,id>⁻¹
  <tt,id>⁻¹ ∻ swap = <id,tt>⁻¹
  assoc ∻ assoc⁻¹ = id
  assoc ∻ (assoc⁻¹ ∻'' r) = r
  assoc⁻¹ ∻ assoc = id
  assoc⁻¹ ∻ (assoc ∻'' r) = r
  swap ∻ swap = id
  swap ∻ (swap ∻'' r) = r
  (r₁ ∻'' r₂) ∻ r₃ = r₁ ∻ (r₂ ∻ r₃)
  ⟨ r₁ ×'' r₂ ⟩ ∻ ⟨ r₃ ×'' r₄ ⟩ = ⟨ r₁ ∻ r₃ × r₂ ∻ r₄ ⟩
  ⟨ r₁ ×'' r₂ ⟩ ∻ (⟨ r₃ ×'' r₄ ⟩ ∻'' r₅) with ⟨ r₁ ∻ r₃ × r₂ ∻ r₄ ⟩
  ... | id = r₅
  ... | r₆ = r₆ ∻'' r₅
  r₁ ∻ r₂ = r₁ ∻'' r₂

  sym : ∀ {S S'} → R S S' → R S' S
  sym (r ∻'' r₁) = sym r₁ ∻ sym r
  sym <id,tt> = <id,tt>⁻¹
  sym <tt,id> = <tt,id>⁻¹
  sym <id,tt>⁻¹ = <id,tt>
  sym <tt,id>⁻¹ = <tt,id>
  sym ⟨ r ×'' r₁ ⟩ = ⟨ sym r × sym r₁ ⟩
  sym assoc = assoc⁻¹
  sym assoc⁻¹ = assoc
  sym id = id
  sym swap = swap

  proof₁ : ∀ {S S'} → R S S' → R' (eval S) (eval S')
  proof₁ (r ∻'' r₁) = proof₁ r ∻' proof₁ r₁
  proof₁ <id,tt> = <id,tt>'
  proof₁ <tt,id> = <tt,id>'
  proof₁ <id,tt>⁻¹ = <id,tt>⁻¹'
  proof₁ <tt,id>⁻¹ = <tt,id>⁻¹'
  proof₁ ⟨ id ×'' r ⟩ = second' (proof₁ r)
  proof₁ ⟨ r ×'' id ⟩ = first'  (proof₁ r)
  proof₁ ⟨ r ×'' r₁ ⟩ = ⟨ proof₁ r ×' proof₁ r₁ ⟩
  proof₁ assoc = assoc'
  proof₁ assoc⁻¹ = assoc⁻¹'
  proof₁ id = id'
  proof₁ swap = swap'

  proof₂ : ∀ {S S'} → R S S' → R' (eval S') (eval S)
  proof₂ r = proof₁ (sym r)

  data NF : Syn → Set where
    tt : NF tt
    var : (x : Var) → NF (var x)
    var_::_ : ∀ {S}(i : Var) → NF S → NF (var i , S)

  record NFP S : Set where
    constructor _⊢_
    field
      {S'} : Syn
      term : NF S'
      proof : R S' S

  merge : ∀ {S S'} → NF S → NF S' → NFP (S , S')
  merge tt n2 = n2 ⊢ <tt,id>⁻¹
  merge (var i) n2 = (var i :: n2) ⊢ id
  merge (var i :: n1) n2 with merge n1 n2
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ id × p ⟩ ∻ assoc)

  norm : (x : Syn) → NFP x
  norm (var x) = (var x) ⊢ id
  norm tt = tt ⊢ id
  norm (x , x₁) with norm x | norm x₁
  ... | t1 ⊢ p1 | t2 ⊢ p2 with merge t1 t2
  ... | t3 ⊢ p3 = t3 ⊢ (p3 ∻ ⟨ p1 × p2 ⟩)

  insert : ∀ {S} → (x : Var) → NF S → NFP (var x , S)
  insert y tt = (var y) ⊢ <id,tt>⁻¹
  insert y (var i) with (F.toℕ y) ℕ.≤? (F.toℕ i)
  ... | yes _ = (var y :: var i) ⊢ id
  ... | no  _ = (var i :: var y) ⊢ swap
  insert y (var i :: n1) with (F.toℕ y) ℕ.≤? (F.toℕ i)
  ... | yes _ = (var y :: (var i :: n1)) ⊢ id
  ... | no  _ with insert y n1
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ id × p ⟩ ∻ (assoc ∻ (⟨ swap × id ⟩ ∻ assoc⁻¹)))

  sort : ∀ {x : Syn} → NF x → NFP x
  sort tt = tt ⊢ id
  sort (var i) = var i ⊢ id
  sort (var i :: n1) with sort n1
  ... | t1 ⊢ p1 with insert i t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ ⟨ id × p1 ⟩)

  normal : (x : Syn) → NFP x
  normal x with norm x
  ... | t1 ⊢ p1 with sort t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ p1)

  open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)
  open import Relation.Nullary

  import Data.Unit
  import Data.Empty

  id≡ : ∀ {S S'} → S ≡ S' → R S S'
  id≡ refl = id

  _≢_ : ∀ {A : Set} → A → A → Set
  x ≢ y = x ≡ y → Data.Empty.⊥

  ≢-cong : ∀ {A B}{x y : A}(f : A → B) → f x ≢ f y → x ≢ y
  ≢-cong f fr refl = fr refl

  var-inj : ∀ {i j : Fin nrVars} → i ≢ j → Syn.var i ≢ var j
  var-inj p refl = p refl

  ,-inj₁ : ∀ {x y a b} → x ≢ y → (x Syn., a) ≢ (y , b)
  ,-inj₁ p refl = p refl

  ,-inj₂ : ∀ {x y a b} → a ≢ b → (x Syn., a) ≢ (y , b)
  ,-inj₂ p refl = p refl

  _≟_ : (x y : Syn) → Dec (x ≡ y)
  var x ≟ var x₁ with x FP.≟ x₁
  var .x₁ ≟ var x₁ | yes refl = yes refl
  ... | no  p    = no (var-inj p)
  var x ≟ tt = no (λ ())
  var x ≟ (y , y₁) = no (λ ())
  tt ≟ var x = no (λ ())
  tt ≟ tt = yes refl
  tt ≟ (y , y₁) = no (λ ())
  (x , x₁) ≟ var x₂ = no (λ ())
  (x , x₁) ≟ tt = no (λ ())
  (x , x₁) ≟ (y , y₁) with x ≟ y | x₁ ≟ y₁
  (x , x₁) ≟ (.x , .x₁) | yes refl | yes refl = yes refl
  (x , x₁) ≟ (y , y₁) | yes p | no ¬p = no (,-inj₂ ¬p)
  (x , x₁) ≟ (y , y₁) | no ¬p | q = no (,-inj₁ ¬p)

  CHECK : Syn → Syn → Set
  CHECK s1 s2 with s1 ≟ s2
  ... | yes p = Data.Unit.⊤
  ... | no  p = Data.Empty.⊥

  rewire : (S₁ S₂ : Syn) → CHECK (NFP.S' (normal S₁)) (NFP.S' (normal S₂)) → R' (eval S₁) (eval S₂)
  rewire s₁ s₂ eq with NFP.S' (normal s₁) ≟ NFP.S' (normal s₂)
  ... | yes p = proof₁
                  ((sym (NFP.proof (normal s₁)) ∻ id≡ p) ∻ NFP.proof (normal s₂))
  rewire _ _ () | no _
    -- proof₂ (NFP.proof (normal s₁)) ∻' (eq ∻' proof₁ (NFP.proof (normal s₂)))

module example where

  open import Data.Vec

  open import Data.Product
  open import Data.Unit

  open import Function

  -- need to etaexpand this because otherwise we get an error
  module STest n M = Syntax Set _×_ ⊤ (λ x x₁ → x → x₁) (λ x → x)
         (λ x x₁ x₂ → x₁ (x x₂)) (λ x → proj₁ x) (λ x → x , tt)
         (λ x → proj₂ x) (λ x → tt , x) (λ x x₁ x₂ → (x (proj₁ x₂)) , (x₁ (proj₂ x₂)))
         (λ x x₁ → (x (proj₁ x₁)) , (proj₂ x₁)) (λ x x₁ → (proj₁ x₁) , (x (proj₂ x₁)))
         (λ x → ((proj₁ x) , (proj₁ (proj₂ x))) , (proj₂ (proj₂ x)))
         (λ x → (proj₁ (proj₁ x)) , ((proj₂ (proj₁ x)) , (proj₂ x)))
         (λ x → (proj₂ x) , (proj₁ x)) n M

  test : (A B C : Set) → (A × B) × C → (B × A) × C
  test A B C = rewire LHS RHS _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

    LHS = (# 0 , # 1) , # 2
    RHS = (# 1 , # 0) , # 2

module example₂ where

  open import Data.Vec

  data Ty : Set where
    _×_ : Ty → Ty → Ty
    ⊤ : Ty

  infix 4 _⟶_

  data _⟶_ : Ty → Ty → Set where
    id' : ∀ {A} → A ⟶ A
    _∻'_ : ∀ {A B C} → A ⟶ B → B ⟶ C → A ⟶ C
    <id,tt>' : ∀ {A} → (A × ⊤) ⟶ A
    <id,tt>⁻¹' : ∀ {A} → A ⟶ (A × ⊤)
    <tt,id>' : ∀ {A} → (⊤ × A) ⟶ A
    <tt,id>⁻¹' : ∀ {A} → A ⟶ (⊤ × A)
    ⟨_×'_⟩   : ∀ {A B C D} → A ⟶ C → B ⟶ D → (A × B) ⟶ (C × D)
    first    : ∀ {A B C} → A ⟶ B → A × C ⟶ B × C
    second   : ∀ {A B C} → B ⟶ C → A × B ⟶ A × C
    assoc'   : ∀ {A B C} → (A × (B × C)) ⟶ ((A × B) × C)
    assoc⁻¹' : ∀ {A B C} → ((A × B) × C) ⟶ (A × (B × C))
    swap'    : ∀ {A B}   → (A × B) ⟶ (B × A)

  module STest n M = Syntax Ty _×_ ⊤ _⟶_ id' _∻'_ <id,tt>' <id,tt>⁻¹' <tt,id>' <tt,id>⁻¹' ⟨_×'_⟩ first second assoc' assoc⁻¹' swap' n M

  test2 : (A B C : Ty) → (A × B) × C ⟶  (B × A) × C
  test2 A B C = rewire ((# 0 , # 1) , # 2) ((# 1 , # 0) , # 2) _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

error: pathspec 'linear-solver.agda' did not match any file(s) known to git


Added draft about well-founded induction.

Ignore-this: f722421546ab538ab5e9b43c374886ff

darcs-hash:20110301042354-3bd4e-2d2931394d9a7b3ef2a548048ac1509561498b32.gz

----------------------------------------------------------------------------
-- Well-founded induction on the natural numbers
----------------------------------------------------------------------------

module Draft.WellFoundedInductionI where

open import FOTC.Base

open import Common.Function

open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI
open import FOTC.Data.Nat.Type

------------------------------------------------------------------------------
-- Well-founded induction on the natural numbers.

wfInd-LT : (P : D → Set) →
           (∀ {n} → N n → (∀ {m} → N m → LT m n → P m) → P n) →
           ∀ {n} → N n → P n
wfInd-LT P accH zN      = accH zN (λ Nm m<0 → ⊥-elim (x<0→⊥ Nm m<0))
wfInd-LT P accH (sN Nn) = accH (sN Nn)
                               (λ Nm m<Sn → helper Nm Nn (wfInd-LT P accH Nn)
                                                   (x<Sy→x≤y Nm Nn m<Sn))
  where
    helper : ∀ {n m} → N n → N m → P m → LE n m → P n
    helper {n} {m} Nn Nm Pm n≤m =
      [ (λ n<m → {!!} )
      , (λ n≡m → helper₁ n≡m Pm)
      ] (x≤y→x<y∨x≡y Nn Nm n≤m)
      where
        helper₁ : ∀ {a b} → a ≡ b → P b → P a
        helper₁ refl Pb = Pb

error: pathspec 'Draft/WellFoundedInductionI.agda' did not match any file(s) known to git


Added a coproduct Sum universe

Added a coproduct Sum universe

open import Function
open import Data.Nat.NP
open import Data.Nat.Properties
open import Data.Unit hiding (_≤_)
open import Data.Sum
open import Data.Product
open import Data.Bits
open import Data.Bool.NP as Bool
open import Relation.Binary.PropositionalEquality

module sum where

private
    ★₁ : Set₂
    ★₁ = Set₁

    ★ : ★₁
    ★ = Set

_≤°_ : ∀ {A : Set}(f g : A → ℕ) → Set
f ≤° g = ∀ x → f x ≤ g x

Sum : ★ → ★
Sum A = (A → ℕ) → ℕ

Count : ★ → ★
Count A = (A → Bit) → ℕ

SumExt : ∀ {A} → Sum A → ★
SumExt sumᴬ = ∀ {f g} → f ≗ g → sumᴬ f ≡ sumᴬ g

CountExt : ∀ {A} → Count A → ★
CountExt countᴬ = ∀ {f g} → f ≗ g → countᴬ f ≡ countᴬ g

SumLin : ∀ {A} → Sum A → ★
SumLin sumᴬ = ∀ f k → sumᴬ (λ x → k * f x) ≡ k * sumᴬ f

SumHom : ∀ {A} → Sum A → ★
SumHom sumᴬ = ∀ f g → sumᴬ (λ x → f x + g x) ≡ sumᴬ f + sumᴬ g

SumMon : ∀ {A} → Sum A → ★
SumMon sumᴬ = ∀ f g → f ≤° g → sumᴬ f ≤ sumᴬ g

record SumProp A : ★ where
  constructor mk
  field
    sum : Sum A
    sum-ext : SumExt sum
    sum-lin : SumLin sum
    sum-hom : SumHom sum
    sum-mon : SumMon sum

  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (Bool.toℕ ∘ f)

  count-ext : CountExt count
  count-ext f≗g = sum-ext (cong Bool.toℕ ∘ f≗g)

open SumProp public

_≈Sum_ : ∀ {A} → (sum₀ sum₁ : Sum A) → ★
sum₀ ≈Sum sum₁ = ∀ f → sum₀ f ≡ sum₁ f

sum⊤ : Sum ⊤
sum⊤ f = f _

μ⊤ : SumProp ⊤
μ⊤ = mk sum⊤ sum⊤-ext sum⊤-lin sum⊤-hom sum⊤-mon
  where
    sum⊤-ext : SumExt sum⊤
    sum⊤-ext f≗g = f≗g _

    sum⊤-lin : SumLin sum⊤
    sum⊤-lin f k = refl

    sum⊤-hom : SumHom sum⊤
    sum⊤-hom f g = refl

    sum⊤-mon : SumMon sum⊤
    sum⊤-mon f g f≤°g = f≤°g tt

sumBit : Sum Bit
sumBit f = f 0b + f 1b

μBit : SumProp Bit
μBit = mk sumBit sumBit-ext sumBit-lin sumBit-hom sumBit-mon
  where
    sumBit-ext : SumExt sumBit
    sumBit-ext f≗g rewrite f≗g 0b | f≗g 1b = refl

    sumBit-lin : SumLin sumBit
    sumBit-lin f k
      rewrite ℕ°.*-comm k (f 0b)
            | ℕ°.*-comm k (f 1b)
            | ℕ°.*-comm k (f 0b + f 1b)
            | ℕ°.distribʳ k (f 0b) (f 1b)
            = refl

    sumBit-hom : SumHom sumBit
    sumBit-hom f g = +-interchange (f 0b) (g 0b) (f 1b) (g 1b)

    sumBit-mon : SumMon sumBit
    sumBit-mon f g f≤°g = f≤°g 0b +-mono f≤°g 1b

infixr 4 _+Sum_

_+Sum_ : ∀ {A B} → Sum A → Sum B → Sum (A ⊎ B)
(sumᴬ +Sum sumᴮ) f = sumᴬ (f ∘ inj₁) + sumᴮ (f ∘ inj₂)

_+μ_ : ∀ {A B} → SumProp A
               → SumProp B
               → SumProp (A ⊎ B)
(μA +μ μB) = mk +-μ +μ-ext +μ-lin +μ-hom +μ-mon
  where
    +-μ = sum μA +Sum sum μB
    +μ-ext : SumExt +-μ
    +μ-ext f≗g rewrite sum-ext μA (f≗g ∘ inj₁) | sum-ext μB (f≗g ∘ inj₂) = refl

    +μ-lin : SumLin +-μ
    +μ-lin f k rewrite sum-lin μA (f ∘ inj₁) k | sum-lin μB (f ∘ inj₂) k
          = sym (proj₁ ℕ°.distrib k (sum μA (f ∘ inj₁)) (sum μB (f ∘ inj₂)))

    +μ-hom : SumHom +-μ
    +μ-hom f g rewrite sum-hom μA (f ∘ inj₁) (g ∘ inj₁) | sum-hom μB (f ∘ inj₂) (g ∘ inj₂)
          = +-interchange (sum μA (f ∘ inj₁)) (sum μA (g ∘ inj₁))
              (sum μB (f ∘ inj₂)) (sum μB (g ∘ inj₂))

    +μ-mon : SumMon +-μ
    +μ-mon f g f≤°g = sum-mon μA (f ∘ inj₁) (g ∘ inj₁) (f≤°g ∘ inj₁)
               +-mono sum-mon μB (f ∘ inj₂) (g ∘ inj₂) (f≤°g ∘ inj₂)

infixr 4 _×Sum_

-- liftM2 _,_ in the continuation monad
_×Sum_ : ∀ {A B} → Sum A → Sum B → Sum (A × B)
(sumᴬ ×Sum sumᴮ) f = sumᴬ (λ x₀ →
                       sumᴮ (λ x₁ →
                         f (x₀ , x₁)))

_×Sum-ext_ : ∀ {A B} {sumᴬ : Sum A} {sumᴮ : Sum B} →
              SumExt sumᴬ → SumExt sumᴮ → SumExt (sumᴬ ×Sum sumᴮ)
(sumA-ext ×Sum-ext sumB-ext) f≗g = sumA-ext (λ x → sumB-ext (λ y → f≗g (x , y)))

infixr 4 _×μ_

_×μ_ : ∀ {A B} → SumProp A
               → SumProp B
               → SumProp (A × B)
(μA ×μ μB)
   = mk (sum μA ×Sum sum μB) (sum-ext μA ×Sum-ext sum-ext μB) lin hom mon
   where
     lin : SumLin (sum μA ×Sum sum μB)
     lin f k rewrite sum-ext μA (λ x → sum-lin μB (λ y → f (x , y)) k) = sum-lin μA (sum μB ∘ curry f) k

     hom : SumHom (sum μA ×Sum sum μB)
     hom f g rewrite sum-ext μA (λ x → sum-hom μB (λ y → f (x , y)) (λ y → g (x , y)))
         = sum-hom μA (sum μB ∘ curry f) (sum μB ∘ curry g)

     mon : SumMon (sum μA ×Sum sum μB)
     mon f g f≤°g = sum-mon μA (sum μB ∘ curry f) (sum μB ∘ curry g) (λ x → sum-mon μB (curry f x) (curry g x)
                      (λ x₁ → f≤°g (x , x₁)))

swapS : ∀ {A B} → Sum (A × B) → Sum (B × A)
swapS sumA×B f = sumA×B (f ∘ swap)

{-
×Sum-swap : ∀ {A B} (sumᴬ : Sum A) (sumᴮ : Sum B) →
              (sumᴬ ×Sum sumᴮ) ≈Sum swapS (sumᴮ ×Sum sumᴬ)
×Sum-swap sumᴬ sumᴮ f = {!!}

-- wrong so far: ×Sum-swap (const 42) (const 1)
-}

-- sum (λ x → f x + g x) ≡ sum f + sum g

sum-const : ∀ {A} (μA : SumProp A) → ∀ k → sum μA (const k) ≡ Card μA * k
sum-const μA k
  rewrite ℕ°.*-comm (Card μA) k
        | sym (sum-lin μA (const 1) k)
        | proj₂ ℕ°.*-identity k = refl

infixr 4 _×Sum-proj₁_ _×Sum-proj₁'_ _×Sum-proj₂_ _×Sum-proj₂'_

_×Sum-proj₁_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₁) ≡ Card μB * sum μA f
(μA ×Sum-proj₁ μB) f
  rewrite sum-ext μA (sum-const μB ∘ f)
        = sum-lin μA f (Card μB)

_×Sum-proj₂_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₂) ≡ Card μA * sum μB f
(μA ×Sum-proj₂ μB) f = sum-const μA (sum μB f)

_×Sum-proj₁'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μA f ≡ sum μA g →
                  sum (μA ×μ μB) (f ∘ proj₁) ≡ sum (μA ×μ μB) (g ∘ proj₁)
(μA ×Sum-proj₁' μB) {f} {g} sumf≡sumg
  rewrite (μA ×Sum-proj₁ μB) f
        | (μA ×Sum-proj₁ μB) g
        | sumf≡sumg = refl

_×Sum-proj₂'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μB f ≡ sum μB g →
                  sum (μA ×μ μB) (f ∘ proj₂) ≡ sum (μA ×μ μB) (g ∘ proj₂)
(μA ×Sum-proj₂' μB) sumf≡sumg = sum-ext μA (const sumf≡sumg)

open import Data.Fin hiding (_+_)
open import Data.Vec.NP as Vec renaming (map to vmap; sum to vsum)

sumFin : ∀ n → Sum (Fin n)
sumFin n f = vsum (vmap f (allFin n))

μFin : ∀ n → SumProp (Fin n)
μFin n = mk (sumFin n) sumFin-ext sumFin-lin sumFin-hom sumFin-mon
  module SumFin where
    sumFin-ext : SumExt (sumFin n)
    sumFin-ext f≗g rewrite map-ext f≗g (allFin n) = refl

    sumFin-lin : SumLin (sumFin n)
    sumFin-lin f x = sum-distribˡ f x (allFin n)

    sumFin-hom : SumHom (sumFin n)
    sumFin-hom f g = sum-linear f g (allFin n)

    sumFin-mon : SumMon (sumFin n)
    sumFin-mon f g f≤°g = sum-mono f g f≤°g (allFin n)

open import Function
open import Data.Nat.NP
open import Data.Nat.Properties
open import Data.Unit hiding (_≤_)
open import Data.Product
open import Data.Bits
open import Data.Bool.NP as Bool
open import Relation.Binary.PropositionalEquality

module sum where

private
    ★₁ : Set₂
    ★₁ = Set₁

    ★ : ★₁
    ★ = Set

_≤°_ : ∀ {A : Set}(f g : A → ℕ) → Set
f ≤° g = ∀ x → f x ≤ g x

Sum : ★ → ★
Sum A = (A → ℕ) → ℕ

Count : ★ → ★
Count A = (A → Bit) → ℕ

SumExt : ∀ {A} → Sum A → ★
SumExt sumᴬ = ∀ {f g} → f ≗ g → sumᴬ f ≡ sumᴬ g

CountExt : ∀ {A} → Count A → ★
CountExt countᴬ = ∀ {f g} → f ≗ g → countᴬ f ≡ countᴬ g

SumLin : ∀ {A} → Sum A → ★
SumLin sumᴬ = ∀ f k → sumᴬ (λ x → k * f x) ≡ k * sumᴬ f

SumHom : ∀ {A} → Sum A → ★
SumHom sumᴬ = ∀ f g → sumᴬ (λ x → f x + g x) ≡ sumᴬ f + sumᴬ g

SumMon : ∀ {A} → Sum A → ★
SumMon sumᴬ = ∀ f g → f ≤° g → sumᴬ f ≤ sumᴬ g

record SumProp A : ★ where
  constructor mk
  field
    sum : Sum A
    sum-ext : SumExt sum
    sum-lin : SumLin sum
    sum-hom : SumHom sum
    sum-mon : SumMon sum

  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (Bool.toℕ ∘ f)

  count-ext : CountExt count
  count-ext f≗g = sum-ext (cong Bool.toℕ ∘ f≗g)

open SumProp public

_≈Sum_ : ∀ {A} → (sum₀ sum₁ : Sum A) → ★
sum₀ ≈Sum sum₁ = ∀ f → sum₀ f ≡ sum₁ f

sum⊤ : Sum ⊤
sum⊤ f = f _

μ⊤ : SumProp ⊤
μ⊤ = mk sum⊤ sum⊤-ext sum⊤-lin sum⊤-hom sum⊤-mon
  where
    sum⊤-ext : SumExt sum⊤
    sum⊤-ext f≗g = f≗g _

    sum⊤-lin : SumLin sum⊤
    sum⊤-lin f k = refl

    sum⊤-hom : SumHom sum⊤
    sum⊤-hom f g = refl

    sum⊤-mon : SumMon sum⊤
    sum⊤-mon f g f≤°g = f≤°g tt

sumBit : Sum Bit
sumBit f = f 0b + f 1b

μBit : SumProp Bit
μBit = mk sumBit sumBit-ext sumBit-lin sumBit-hom sumBit-mon
  where
    sumBit-ext : SumExt sumBit
    sumBit-ext f≗g rewrite f≗g 0b | f≗g 1b = refl

    sumBit-lin : SumLin sumBit
    sumBit-lin f k
      rewrite ℕ°.*-comm k (f 0b)
            | ℕ°.*-comm k (f 1b)
            | ℕ°.*-comm k (f 0b + f 1b)
            | ℕ°.distribʳ k (f 0b) (f 1b)
            = refl

    sumBit-hom : SumHom sumBit
    sumBit-hom f g = +-interchange (f 0b) (g 0b) (f 1b) (g 1b)

    sumBit-mon : SumMon sumBit
    sumBit-mon f g f≤°g = f≤°g 0b +-mono f≤°g 1b

infixr 4 _×Sum_

-- liftM2 _,_ in the continuation monad
_×Sum_ : ∀ {A B} → Sum A → Sum B → Sum (A × B)
(sumᴬ ×Sum sumᴮ) f = sumᴬ (λ x₀ →
                       sumᴮ (λ x₁ →
                         f (x₀ , x₁)))

_×Sum-ext_ : ∀ {A B} {sumᴬ : Sum A} {sumᴮ : Sum B} →
              SumExt sumᴬ → SumExt sumᴮ → SumExt (sumᴬ ×Sum sumᴮ)
(sumA-ext ×Sum-ext sumB-ext) f≗g = sumA-ext (λ x → sumB-ext (λ y → f≗g (x , y)))

infixr 4 _×μ_

_×μ_ : ∀ {A B} → SumProp A
               → SumProp B
               → SumProp (A × B)
(μA ×μ μB)
   = mk (sum μA ×Sum sum μB) (sum-ext μA ×Sum-ext sum-ext μB) lin hom mon
   where
     lin : SumLin (sum μA ×Sum sum μB)
     lin f k rewrite sum-ext μA (λ x → sum-lin μB (λ y → f (x , y)) k) = sum-lin μA (sum μB ∘ curry f) k

     hom : SumHom (sum μA ×Sum sum μB)
     hom f g rewrite sum-ext μA (λ x → sum-hom μB (λ y → f (x , y)) (λ y → g (x , y)))
         = sum-hom μA (sum μB ∘ curry f) (sum μB ∘ curry g)

     mon : SumMon (sum μA ×Sum sum μB)
     mon f g f≤°g = sum-mon μA (sum μB ∘ curry f) (sum μB ∘ curry g) (λ x → sum-mon μB (curry f x) (curry g x)
                      (λ x₁ → f≤°g (x , x₁)))

swapS : ∀ {A B} → Sum (A × B) → Sum (B × A)
swapS sumA×B f = sumA×B (f ∘ swap)

{-
×Sum-swap : ∀ {A B} (sumᴬ : Sum A) (sumᴮ : Sum B) →
              (sumᴬ ×Sum sumᴮ) ≈Sum swapS (sumᴮ ×Sum sumᴬ)
×Sum-swap sumᴬ sumᴮ f = {!!}

-- wrong so far: ×Sum-swap (const 42) (const 1)
-}

-- sum (λ x → f x + g x) ≡ sum f + sum g

sum-const : ∀ {A} (μA : SumProp A) → ∀ k → sum μA (const k) ≡ Card μA * k
sum-const μA k
  rewrite ℕ°.*-comm (Card μA) k
        | sym (sum-lin μA (const 1) k)
        | proj₂ ℕ°.*-identity k = refl

infixr 4 _×Sum-proj₁_ _×Sum-proj₁'_ _×Sum-proj₂_ _×Sum-proj₂'_

_×Sum-proj₁_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₁) ≡ Card μB * sum μA f
(μA ×Sum-proj₁ μB) f
  rewrite sum-ext μA (sum-const μB ∘ f)
        = sum-lin μA f (Card μB)

_×Sum-proj₂_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₂) ≡ Card μA * sum μB f
(μA ×Sum-proj₂ μB) f = sum-const μA (sum μB f)

_×Sum-proj₁'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μA f ≡ sum μA g →
                  sum (μA ×μ μB) (f ∘ proj₁) ≡ sum (μA ×μ μB) (g ∘ proj₁)
(μA ×Sum-proj₁' μB) {f} {g} sumf≡sumg
  rewrite (μA ×Sum-proj₁ μB) f
        | (μA ×Sum-proj₁ μB) g
        | sumf≡sumg = refl

_×Sum-proj₂'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μB f ≡ sum μB g →
                  sum (μA ×μ μB) (f ∘ proj₂) ≡ sum (μA ×μ μB) (g ∘ proj₂)
(μA ×Sum-proj₂' μB) sumf≡sumg = sum-ext μA (const sumf≡sumg)

open import Data.Fin hiding (_+_)
open import Data.Vec.NP as Vec renaming (map to vmap; sum to vsum)

sumFin : ∀ n → Sum (Fin n)
sumFin n f = vsum (vmap f (allFin n))

μFin : ∀ n → SumProp (Fin n)
μFin n = mk (sumFin n) sumFin-ext sumFin-lin sumFin-hom sumFin-mon
  module SumFin where
    sumFin-ext : SumExt (sumFin n)
    sumFin-ext f≗g rewrite map-ext f≗g (allFin n) = refl

    sumFin-lin : SumLin (sumFin n)
    sumFin-lin f x = sum-distribˡ f x (allFin n)

    sumFin-hom : SumHom (sumFin n)
    sumFin-hom f g = sum-linear f g (allFin n)

    sumFin-mon : SumMon (sumFin n)
    sumFin-mon f g f≤°g = sum-mono f g f≤°g (allFin n)


Added issue.

Added issue.

Ignore-this: 76bbff01b674d2413dffeddea8b4e57e

darcs-hash:20110923235106-3bd4e-3df2784e27525650905ef511fa96bcc49badd2f5.gz

error: pathspec 'Issues/Agda365.agda' did not match any file(s) known to git


Added missing file.

Added missing file.

Ignore-this: 845e884251e48165cbb2f45f5b3dab57

darcs-hash:20100908153610-3bd4e-e20fc7f615975afb00093672d6118d768d2a3b37.gz

error: pathspec 'LTC/Data/List/Core.agda' did not match any file(s) known to git


FMSB: agda model of lambda madnesses

FMSB: agda model of lambda madnesses

module FMSB where

data Nat : Set where
  ze : Nat
  su : Nat -> Nat

data Lam (X : Nat -> Set)(n : Nat) : Set where
  var : X n -> Lam X n
  app : Lam X n -> Lam X n -> Lam X n
  lam : Lam X (su n) -> Lam X n

_->>_ : {I : Set}(X Y : I -> Set) -> Set
X ->> Y = {i : _} -> X i -> Y i

fmsub : {X Y : Nat -> Set} -> (X ->> Lam Y) -> Lam X ->> Lam Y
fmsub sb (var x)   = sb x
fmsub sb (app f s) = app (fmsub sb f) (fmsub sb s)
fmsub sb (lam b)   = lam (fmsub sb b)

data Fin : Nat -> Set where
  ze : {n : Nat} -> Fin (su n)
  su : {n : Nat} -> Fin n -> Fin (su n)

D : (Nat -> Set) -> Nat -> Set
D F n = F (su n)

weak : {F : Nat -> Set} -> (Fin ->> F) -> (F ->> D F) ->
       {m n : Nat}-> (Fin m -> F n) -> D Fin m -> D F n
weak v w f ze      = v ze
weak v w f (su x)  = w (f x)

_+_ : Nat -> Nat -> Nat
ze    + y = y
su x  + y = su (x + y)

_!+_ : (Nat -> Set) -> Nat -> (Nat -> Set)
F !+ n = \ m -> F (m + n)

weaks : {F : Nat -> Set} -> (Fin ->> F) -> (F ->> D F) ->
        {m n : Nat}-> (Fin m -> F n) -> (Fin !+ m) ->> (F !+ n)
weaks v w f {ze}    = f
weaks v w f {su i}  = weak v w (weaks v w f {i})

jing : {m n : Nat} -> Lam Fin (m + n) -> Lam (Fin !+ n) m
jing (var x) = var x
jing (app f s) = app (jing f) (jing s)
jing (lam t) = lam (jing t)

gnij : {m n : Nat} -> Lam (Fin !+ n) m -> Lam Fin (m + n)
gnij (var x) = var x
gnij (app f s) = app (gnij f) (gnij s)
gnij (lam t) = lam (gnij t)

ren : {m n : Nat} -> (Fin m -> Fin n) -> Lam Fin m -> Lam Fin n
ren f t = gnij (fmsub (\ {i} x -> var (weaks (\ z -> z) su f {i} x)) {ze} (jing t))

sub : {m n : Nat} -> (Fin m -> Lam Fin n) -> Lam Fin m -> Lam Fin n
sub {m}{n} f t = gnij {ze} (fmsub (\ {i} x -> jing {i} (weaks {Lam Fin} var (ren su) f {i} x)) (jing {ze} t))

error: pathspec 'models/FMSB.agda' did not match any file(s) known to git


Add Data.One.Param.Binary

Add Data.One.Param.Binary

{-# OPTIONS --without-K #-}
open import Type.Param.Binary
open import Data.Unit renaming (⊤ to 𝟙; tt to 0₁)

module Data.One.Param.Binary where

record ⟦𝟙⟧ (x₁ x₂ : 𝟙) : Set₀ where
  constructor ⟦0₁⟧

error: pathspec 'lib/Data/One/Param/Binary.agda' did not match any file(s) known to git


Added an issue related to lazyness.

Added an issue related to lazyness.

Ignore-this: 78e6522f8fbc0febe67f3a9e58e8962c

darcs-hash:20110818183110-3bd4e-6c6348300e0e28fc130a4c545ea7dcb38068e3cd.gz

module Issues.Lazyness where

{-
$ agda2atp Issues/Lazyness.agda

yields

An internal error has occurred. Please report this as a bug.
Location of the error: src/FOL/Translation/Internal/Terms.hs:486

but

$ agda2atp -v 20 Issues/Lazyness.agda

yields

An internal error has occurred. Please report this as a bug.
Location of the error: src/AgdaLib/Syntax/DeBruijn.hs:152

The internal error should be the same.
-}

postulate
  D          : Set
  true false : D
  not        : D → D

data _≡_ (x : D) : D → Set where
  refl : x ≡ x

data Bool : D → Set where
  tB : Bool true
  fB : Bool false

foo : ∀ {b0 b1 b2} →
      Bool b1 →
      Bool b2 →
      b0 ≡ not b1 →
      b2 ≡ b2
foo      tB Bb2 b0-eq = refl
foo {b0} fB Bb2 b0-eq = refl
  where
  as : D
  as = b0

  bs : D
  bs = not as
  {-# ATP definition bs #-}

  postulate bar : bs ≡ bs
  {-# ATP prove bar #-}

error: pathspec 'Issues/Lazyness.agda' did not match any file(s) known to git


Model some simple descriptions in Agda.

Model some simple descriptions in Agda.

{-# OPTIONS --universe-polymorphism #-}
module Ornament where

open import Data.Nat using (ℕ)
open import Data.Fin
open import Data.Bool
open import Data.Product
open import Data.Unit

infix 4 _≡_

data _≡_ {a} {A : Set a} (x : A) : A → Set a where
  refl : x ≡ x

--

-- Modified from Conor's original HOAS presentation

data Desc (I : Set) : Set₁ where
  -- read field in A; continue, given its value
  -- I don't think this is really what we want -- want parametricity
  arg : (a : Set) -> (a -> Desc I) -> Desc I

  -- read an indexed subnode; continue regardless
  rec : I -> Desc I -> Desc I

  -- stop reading and return the node’s index
  ret : I -> Desc I

  -- choice between n different constructors
  choice : (n : ℕ) -> (Fin n -> Desc I) -> Desc I

-- The semantics ("extension") of an indexed container
⟦_⟧ : ∀{I} -> Desc I -> (I -> Set) -> I -> Set
⟦ arg A D ⟧ R i = Σ A λ a → ⟦ D a ⟧ R i
⟦ rec h D ⟧ R i = R h × ⟦ D ⟧ R i
⟦ ret o ⟧ R i = o ≡ i
⟦ choice n D ⟧ R i =  Σ (Fin n) λ #n -> ⟦ D #n ⟧ R i

-- This is really the least fixpoint operator
data Data {I}(D : Desc I)(i : I) : Set where
  ⟨_⟩ : ⟦ D ⟧ (Data D) i -> Data D i

-- TODO think about codata / greatest fixed point
-- data CoData {I}(D : Desc I)(i : I) : Set where
--   ⟩_⟨ :

--

NatChoiceDesc : Desc ⊤
NatChoiceDesc = choice 2 λ
  { zero -> ret tt
  ; (suc n) -> rec tt (ret tt)
  }

NatChoice : Set
NatChoice = Data NatChoiceDesc tt

zeChoice : NatChoice
zeChoice = ⟨ zero , refl ⟩

suChoice : NatChoice -> NatChoice
suChoice n = ⟨ suc zero , n , refl ⟩

--

NatDesc : Desc ⊤
NatDesc = arg Bool λ
  { true -> ret tt
  ; false -> rec tt (ret tt)
  }

Nat : Set
Nat = Data NatDesc tt

ze : Nat
ze = ⟨ true , refl ⟩

su : Nat -> Nat
su n = ⟨ false , n , refl ⟩

--

VecDesc : Set -> Desc Nat
VecDesc X = arg Bool λ
  { false -> ret ze
  ; true -> arg X λ _ -> arg Nat λ n -> rec n (ret (su n))
  }

Vec : Set -> Nat -> Set
Vec X n = Data (VecDesc X) n

nil : ∀{X} -> Vec X ze
nil = ⟨ false , refl ⟩

cons : ∀{X} -> (n : Nat) -> X -> Vec X n -> Vec X (su n)
cons n x xs = ⟨ true , x , n , xs , refl ⟩

error: pathspec 'models/Ornament.agda' did not match any file(s) known to git


Evens

Evens

open import Base

open import Nat

open import Logic

module Evens  where

data Even : ℕ → Type where
  0even : Even 0
  _+2even : {n : ℕ} → Even n → Even (succ (succ n))

4even = (0even +2even) +2even

1odd : Even 1 → False
1odd ()

module n|n+1even where
  P : ℕ → Type
  P n = (Even n) ⊕ (Even (succ n))

  step : {n : ℕ} → P n → P (succ n)
  step (ι₁ p) = ι₂(p +2even)
  step (ι₂ p) = ι₁ p

  thm : (n : ℕ) → P n
  thm 0 = ι₁ 0even
  thm (succ n) = step (thm n)

value : {n : ℕ} → Even n → ℕ
value 0even = 0
value (p +2even) = succ (succ (value p))

half : (n : ℕ) → Even n → ℕ
half .0 0even = 0
half (succ (succ n)) (p +2even) = succ (half n p)

double : (n : ℕ) → Σ ℕ Even
double 0 = [ 0 , 0even ]
double (succ n) = [ (succ (succ (proj₁ (double n)))) , (proj₂ (double n)) +2even ]

module Collatz where
  frompf : (n : ℕ) → n|n+1even.P n → ℕ
  frompf n (ι₁ p) = half n p
  frompf n (ι₂ p) = (3 * n) + 1

  fn = λ n → frompf n (n|n+1even.thm n)

error: pathspec 'livecode/Evens.agda' did not match any file(s) known to git


Added missing file.

Added missing file.

Ignore-this: 5677ad139f7c982e3b099d3b8d5c5236

darcs-hash:20100713210639-3bd4e-665913e7dccafb00169212791811bbcd4be0c90d.gz

------------------------------------------------------------------------------
-- Properties related with lists of natural numbers
------------------------------------------------------------------------------

module LTC.Data.Nat.List.Properties where

open import LTC.Minimal

open import LTC.Data.Nat
open import LTC.Data.Nat.List.Type
open import LTC.Data.List

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

++-ListN : {ds es : D} → ListN ds → ListN es → ListN (ds ++ es)
++-ListN {es = es} nilLN esL = prf
  where
    postulate prf : ListN ([] ++ es)
    {-# ATP prove prf #-}

++-ListN {es = es} (consLN {d} {ds} Nd LNds) LNes = prf (++-ListN LNds LNes)
  where
    postulate prf : ListN (ds ++ es) →
                    ListN ((d ∷ ds) ++ es)
    {-# ATP prove prf #-}

error: pathspec 'LTC/Data/Nat/List/Properties.agda' did not match any file(s) known to git


Isomorphism.agda

Isomorphism.agda

{- How this proof can be used for crypto, in particular ElGamal to DDH

  the Group A is ℤq with modular addition as operation
  the Group B is the cyclic group with order q

  φ is g^, the proof only need that it is a group homomorphism
  and that it has a right inverse

  we require that the explore (for type A) function (should work with only summation)
  is Stable under addition of A (notice that we have flip in there that is so that
  we don't need commutativity

  finally we require that the explore function respects extensionality

  This proof adds φ⁻¹ m, because adding a constant is stable under the
  big op F, this addition can then be pulled homomorphically through
  f, to become a, multiplication by m.
-}
open import Type using (Type_)
open import Level.NP
open import Function.NP
open import Relation.Binary.PropositionalEquality.NP
open ≡-Reasoning

module Algebra.Group.Isomorphism where

module M
  {a}{A  : Type a}
  {b}{B  : Type b}
  {c}{C  : Type c}
  (φ     : A → B)
  (φ⁻¹   : B → A)
  (φ-sur : ∀ {x} → φ (φ⁻¹ x) ≡ x)
  (_+_   : Op₂ A)
  (_*_   : Op₂ B)
  (φ-+-* : ∀ {x y} → φ (x + y) ≡ φ x * φ y)
  (F     : (A → B) → C)
  (F=    : ∀ {f g : A → B} → f ≗ g → F f ≡ F g)
  (Fφ+   : ∀ {k} → F φ ≡ F (φ ∘ _+_ k))
  {m     : B}
  where

  *-stable : F φ ≡ F (_*_ m ∘ φ)
  *-stable =
    F φ                  ≡⟨ Fφ+ ⟩
    F (φ ∘ _+_ (φ⁻¹ m))  ≡⟨ F= (λ x → φ (φ⁻¹ m + x)   ≡⟨ φ-+-* ⟩
                                       φ (φ⁻¹ m) * φ x ≡⟨ ap₂ _*_ φ-sur idp ⟩
                                       m * φ x         ∎) ⟩
    F (_*_ m ∘ φ)        ∎

open import Algebra.Group
open import Algebra.Group.Homomorphism

record GroupIsomorphism
         {a}{A  : Type a}
         {b}{B  : Type b}
         (G+ : Group A)
         (G* : Group B)
          : Set(a ⊔ b) where
  open Additive-Group G+
  open Multiplicative-Group G*

  field
    φ : A → B -- TODO
    -- hom : GroupHomomorphism G+ G* φ
    φ-+-* : ∀ {x y} → φ (x + y) ≡ φ x * φ y
    φ⁻¹   : B → A
    φ-sur : ∀ {x} → φ (φ⁻¹ x) ≡ x
    -- φ-inj

module N
  {a}{A  : Type a}
  {b}{B  : Type b}
  {c}{C  : Type c}
  (G+ : Group A)
  (G* : Group B)
  (φ-iso : GroupIsomorphism G+ G*)
  (open Additive-Group G+)
  (open Multiplicative-Group G*)
  (open GroupIsomorphism φ-iso)
  (F     : (A → B) → C)
  (F=    : ∀ {f g : A → B} → f ≗ g → F f ≡ F g)
  (F+    : ∀ {k φ} → F φ ≡ F (φ ∘ _+_ k))
  {m     : B}
  where

  *-stable : F φ ≡ F (_*_ m ∘ φ)
  *-stable =
    F φ                  ≡⟨ F+ ⟩
    F (φ ∘ _+_ (φ⁻¹ m))  ≡⟨ F= (λ x → φ (φ⁻¹ m + x)   ≡⟨ φ-+-* ⟩
                                       φ (φ⁻¹ m) * φ x ≡⟨ ap₂ _*_ φ-sur idp ⟩
                                       m * φ x         ∎) ⟩
    F (_*_ m ∘ φ)        ∎

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

error: pathspec 'lib/Algebra/Group/Isomorphism.agda' did not match any file(s) known to git


Added draft: Bug related with the general hints.

Ignore-this: 267b8d101ed62652325039228cd3388e

darcs-hash:20110207142449-3bd4e-100c2748092b672c228f89a114d3c8c79e94a6aa.gz

module Draft.Bugs.N0 where

open import LTC.Base
open import LTC.Data.Nat

-- TODO: Bug. The agda2atp tool does not translate the general hints.

{-# ATP hint zN #-}
{-# ATP hint sN #-}

postulate
 N0 : N zero
{-# ATP prove N0 #-}

error: pathspec 'Draft/Bugs/N0.agda' did not match any file(s) known to git


Ok Naive/FC

Ok Naive/FC

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/zeitraffer/agda-cats.git/'


Added note on the identity type from refl and J.

Ignore-this: bcfc109f1e68f635d7368060daf1fb3e

darcs-hash:20111001132925-3bd4e-c3c10b7438f8b4fd9502b8ac2b8f0276332d6c76.gz

------------------------------------------------------------------------------
-- The identity type
------------------------------------------------------------------------------

-- We can prove the properties of equality used in the formalization
-- of FOTC, from refl and J.

module IdentityType where

infix 7 _≡_

postulate
  D    : Set
  _≡_  : D → D → Set
  refl : ∀ {x} → x ≡ x
  J    : (C : ∀ x y → x ≡ y → Set) →
         (∀ x → (C x x refl)) →
         ∀ x y → (c : x ≡ y) → C x y c

-- From Thorsten's slides: A short history of equality.
sym : ∀ {x y} → x ≡ y → y ≡ x
sym {x} {y} = J (λ x' y' _ → y' ≡ x') (λ x' → refl) x y

-- From Thorsten's slides: A short history of equality.
trans : ∀ {x y z} → x ≡ y → y ≡ z → x ≡ z
trans {x} {y} {z} = J (λ x' y' _ → y' ≡ z → x' ≡ z) (λ x' pr → pr) x y

subst : ∀ {x} {y} → (P : D → Set) → x ≡ y → P x → P y
subst {x} {y} P x≡y = J (λ x' y' _ → P x' → P y') (λ x' pr → pr) x y x≡y

error: pathspec 'Draft/IdentityType.agda' did not match any file(s) known to git


{-# OPTIONS --without-K #-}
open import Function.NP
open import Type
open import Level.NP
open import Data.Product.NP using (Σ; _×_; _,_) renaming (proj₁ to fst)
open import Data.One using (𝟙)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; !_; _∙_; refl; ap; coe; coe!; subst)
open import Function.Extensionality
open import HoTT
open import Data.ShapePolymorphism
open Equivalences
open import Type

open import Control.Protocol.InOut
open import Control.Protocol.End
import Control.Protocol.Core as C
open C using (end;com)

module Control.Protocol.Alternate where

data Proto : InOut → ★₁ where
  end : ∀ {io} → Proto io
  com : (io : InOut){M : ★₀}(P : M → Proto (dualᴵᴼ io)) → Proto io

pattern recv P = com In  P
pattern send P = com Out P

module _ {{_ : FunExt}} where
    com= : ∀ io {M₀ M₁}(M= : M₀ ≡ M₁)
             {P₀ P₁}(P= : ∀ m₀ → P₀ m₀ ≡ P₁ (coe M= m₀))
           → Proto.com io P₀ ≡ com io P₁
    com= io refl P= = ap (com _) (λ= P=)

    module _ io
             {M₀ M₁}(M≃ : M₀ ≃ M₁)
             {P₀ P₁}
             (P= : ∀ m₀ → P₀ m₀ ≡ P₁ (–> M≃ m₀))
             {{_ : UA}} where
        com≃ : com io P₀ ≡ com io P₁
        com≃ = com= io (ua M≃) λ m → P= m ∙ ap P₁ (! coe-β M≃ m)

    send= = com= Out
    send≃ = com≃ Out
    recv= = com= In
    recv≃ = com≃ In

    com=′ : ∀ io {M}{P₀ P₁ : M → Proto _}(P= : ∀ m → P₀ m ≡ P₁ m) → com io P₀ ≡ com io P₁
    com=′ io = com= io refl

    send=′ : ∀ {M}{P₀ P₁ : M → Proto _}(P= : ∀ m → P₀ m ≡ P₁ m) → send P₀ ≡ send P₁
    send=′ = send= refl

    recv=′ : ∀ {M}{P₀ P₁ : M → Proto _}(P= : ∀ m → P₀ m ≡ P₁ m) → recv P₀ ≡ recv P₁
    recv=′ = recv= refl

P⟦_⟧ : ∀ {io} → Proto io → C.Proto
P⟦ end      ⟧ = end
P⟦ com io P ⟧ = com io λ m → P⟦ P m ⟧

⟦_⟧ : ∀ {io} → Proto io → ★
⟦ P ⟧ = C.⟦ P⟦ P ⟧ ⟧

dual : ∀ {io} → Proto io → Proto (dualᴵᴼ io)
dual end        = end
dual (com io P) = com (dualᴵᴼ io) λ m → dual (P m)

module _ {io}(P : Proto io) where
    ⟦_⊥⟧ : ★
    ⟦_⊥⟧ = ⟦ dual P ⟧

    Log : ★
    Log = C.⟦ C.source-of P⟦ P ⟧ ⟧

module _ {{_ : FunExt}} where
    P⟦_⊥⟧ : ∀ {io}(P : Proto io) → C.dual P⟦ P ⟧ ≡ P⟦ dual P ⟧
    P⟦ end      ⊥⟧ = refl
    P⟦ com io P ⊥⟧ = C.com= refl refl λ m → P⟦ P m ⊥⟧

    telecom : ∀ {io} (P : Proto io) → ⟦ P ⟧ → ⟦ P ⊥⟧ → Log P
    telecom P t u = C.telecom P⟦ P ⟧ t (subst C.⟦_⟧ (! P⟦ P ⊥⟧) u)

send′ : ★ → Proto In → Proto Out
send′ M P = send λ (_ : M) → P

recv′ : ★ → Proto Out → Proto In
recv′ M P = recv λ (_ : M) → P

module _ {{_ : FunExt}} where
    dual-involutive : ∀ {io} (P : Proto io) → subst Proto (dualᴵᴼ-involutive io) (dual (dual P)) ≡ P
    dual-involutive {In}  end      = refl
    dual-involutive {Out} end      = refl
    dual-involutive       (send P) = com=′ _ λ m → dual-involutive (P m)
    dual-involutive       (recv P) = com=′ _ λ m → dual-involutive (P m)

    {-
    dual-equiv : Is-equiv dual
    dual-equiv = self-inv-is-equiv dual-involutive

    dual-inj : ∀ {P Q} → dual P ≡ dual Q → P ≡ Q
    dual-inj = Is-equiv.injective dual-equiv
    -}
-- -}
-- -}
-- -}
-- -}

error: pathspec 'Control/Protocol/Alternate.agda' did not match any file(s) known to git


one-time-semantic-security.agda

one-time-semantic-security.agda

module one-time-semantic-security where

open import Function
open import Data.Nat
open import flat-funs
open import Data.Vec using (splitAt)
open import program-distance
open import Data.Bits
open import flipbased-implem
open import Data.Product
open import Relation.Binary.PropositionalEquality

Coins = ℕ

-- module AbsSemSec (|M| |C| : ℕ) {FunPower : Set} {t} {T : Set t}
--                  (♭Funs : PoweredFlatFuns FunPower T) where
module AbsSemSec (|M| |C| : ℕ) {t} {T : Set t}
                 (♭Funs : FlatFuns T) where

  open FlatFuns ♭Funs

  M = `Bits |M|
  C = `Bits |C|

  record AbsSemSecAdv (|R| : Coins) : Set where
    constructor mk

    field
      {|S|} : ℕ

    S = `Bits |S|
    R = `Bits |R|

    field
      step₀ : R `→ (M `× M) `× S
      step₁ : C `× S `→ `Bit
      -- step₀ : ⟨ p₀ ⟩ R ↝ (M `× M) `× S
      -- step₁ : ⟨ p₁ ⟩ C `× S ↝ `Bit

  SemSecReduction : ∀ (f : Coins → Coins) → Set
  SemSecReduction f = ∀ {c} → AbsSemSecAdv c → AbsSemSecAdv (f c)

  -- runAdv is not the good name
  -- runAdv : ∀ {p} (A : AbsSemSecAdv p) → ⟨ ? ⟩ (C `× AbsSemSecAdv.R A) ↝ (M `× M) `× Bit
  -- runAdv (mk A-step₀ A-step₁) C = A-step₀ >>> id *** (const C &&& id >>> A-step₁)

{-
module FFF |M| |C| {♭Funs : FlatFuns ⊤ Set}
               (♭ops : FlatFunsOps _ ♭Funs)
               (run : ∀ {i o} → FlatFuns.⟨_⟩_↝_ ♭Funs _ i o → i → o) where
  open AbsSemSec |M| |C| ♭Funs
  module FunSemSecAdv {|R|} (A : AbsSemSecAdv |R|) where
    open AbsSemSecAdv A public
    open FlatFunsOps ♭ops
    step₀O : ⟨ _ ⟩ R ↝ ((⟨ _ ⟩ Bit ↝ M) × S)
    step₀O = {!run step₀!} >>> {!proj!} *** idO
-}

-- Here we use Agda functions for FlatFuns.
module FunSemSec (prgDist : PrgDist) (|M| |C| : ℕ) where
  open PrgDist prgDist
  open AbsSemSec |M| |C| fun♭Funs
  open FlatFunsOps fun♭Ops

  M² = Bit → M

  Enc : ∀ cc → Set
  Enc cc = M → ↺ cc C

  Tr : (cc₀ cc₁ : Coins) → Set
  Tr cc₀ cc₁ = Enc cc₀ → Enc cc₁

  FunSemSecAdv : Coins → Set
  -- FunSemSecAdv |R| = AbsSemSecAdv (mk _ _ |R|)
  FunSemSecAdv = AbsSemSecAdv

  module FunSemSecAdv {|R|} (A : FunSemSecAdv |R|) where
    open AbsSemSecAdv A public

    step₀F : R → (M² × S)
    step₀F = step₀ >>> proj *** idO

    step₀↺ : ↺ |R| (M² × S)
    step₀↺ = mk step₀F

    step₁F : S → C → Bit
    step₁F s c = step₁ (c , s)

  -- Returing 0 means Chal wins, Adv looses
  --          1 means Adv  wins, Chal looses
  runSemSec : ∀ {cc ca} (E : Enc cc) (A : FunSemSecAdv ca) b → ↺ (ca + cc) Bit
  runSemSec E A b
    = A-step₀ >>= λ { (m , s) → map↺ (A-step₁ s) (E (m b)) }
    where open FunSemSecAdv A renaming (step₀↺ to A-step₀; step₁F to A-step₁)

  _⇄_ : ∀ {cc ca} (E : Enc cc) (A : FunSemSecAdv ca) b → ↺ (ca + cc) Bit
  _⇄_ = runSemSec

  runAdv : ∀ {|R|} → FunSemSecAdv |R| → C → Bits |R| → (M × M) × Bit
  runAdv (mk A-step₀ A-step₁) C = A-step₀ >>> id *** (const C &&& id >>> A-step₁)

  _≗A_ : ∀ {p} (A₁ A₂ : FunSemSecAdv p) → Set
  A₀ ≗A A₁ = ∀ C R → runAdv A₀ C R ≡ runAdv A₁ C R

  change-adv : ∀ {cc ca} {E : Enc cc} {A₁ A₂ : FunSemSecAdv ca} → A₁ ≗A A₂ → (E ⇄ A₁) ≗⅁ (E ⇄ A₂)
  change-adv {ca = ca} {A₁ = _} {_} pf b R with splitAt ca R
  change-adv {E = E} {A₁} {A₂} pf b ._ | pre Σ., post , refl = trans (cong proj₂ (helper₀ A₁)) helper₂
     where open FunSemSecAdv
           helper₀ = λ A → pf (run↺ (E (proj (proj₁ (step₀ A pre)) b)) post) pre
           helper₂ = cong (λ m → step₁ A₂ (run↺ (E (proj (proj₁ m) b)) post , proj₂ (step₀ A₂ pre)))
                          (helper₀ A₂)

  module Unused (Power : Set) (coins : Power → Coins) where
  -- NP: not sure about these two. such a function has acess to the two encryption

    SemBroken : ∀ {cc} (E : Enc cc) → Power → Set
    SemBroken E power = ∃ (λ (A : FunSemSecAdv (coins power)) → breaks (E ⇄ A))

    -- functions.
    -- SemSecReduction p₀ p₁ E₀ E₁:
    --   security of E₀ reduces to security of E₁
    --   breaking E₁ reduces to breaking E₀
    SemSecReduction' : ∀ (p₀ p₁ : Power) {cc₀ cc₁} (E₀ : Enc cc₀) (E₁ : Enc cc₁) → Set
    SemSecReduction' p₀ p₁ E₀ E₁ = SemBroken E₁ p₁ → SemBroken E₀ p₀

  SafeSemSecReduction : ∀ (f : Coins → Coins) {cc₀ cc₁} (E₀ : Enc cc₀) (E₁ : Enc cc₁) → Set
  SafeSemSecReduction f E₀ E₁ =
     ∃ λ (red : SemSecReduction f) →
       ∀ {c} A → (E₀ ⇄ A) ⇓ (E₁ ⇄ red {c} A)

  SemSecTr : ∀ {cc₀ cc₁} (f : Coins → Coins) (tr : Tr cc₀ cc₁) → Set
  SemSecTr {cc₀} f tr = ∀ {E : Enc cc₀} → SafeSemSecReduction f (tr E) E

  -- SemSecReductionToOracle : ∀ (p₀ p₁ : Power) {cc} (E : Enc cc) → Set
  -- SemSecReductionToOracle = SemBroken E p₀ → Oracle p₁

error: pathspec 'one-time-semantic-security.agda' did not match any file(s) known to git


module Data.Tree.Binary.Perfect.Any where

open import Level
open import Relation.Binary.PropositionalEquality
open import prefect-bintree

data Any {a p} {A : Set a} (P : A → Set p) : ∀ {n} → Tree A n → Set (a ⊔ p) where
  leaf  : ∀ {x} (Px : P x) → Any P (leaf x)
  left  : ∀ {n} {t₀ t₁ : Tree A n} → Any P t₀ → Any P (fork t₀ t₁)
  right : ∀ {n} {t₀ t₁ : Tree A n} → Any P t₁ → Any P (fork t₀ t₁)

pattern here = Any.leaf

data All {a p} {A : Set a} (P : A → Set p) : ∀ {n} → Tree A n → Set (a ⊔ p) where
  leaf  : ∀ {x} (Px : P x) → All P (leaf x)
  fork  : ∀ {n} {t₀ t₁ : Tree A n} → All P t₀ → All P t₁ → All P (fork t₀ t₁)

_∈_ : ∀ {a} {A : Set a} (x : A) {n} → Tree A n → Set a
x ∈ t = Any (_≡_ x) t

lookup : ∀ x t → Dec (x ∈ t)

P ⇒ Q → All P t → All Q (map f t)

error: pathspec 'Data/Tree/Binary/Perfect/Any.agda' did not match any file(s) known to git


added Darais

added Darais

-- Author: David Darais
--
-- This is a dependent de Bruijn encoding of STLC with proofs for
-- progress and preservation. This file has zero dependencies and is
-- 100% self-contained.
--
-- Because there is only a notion of well-typed terms (non-well-typed
-- terms do not exist), preservation is merely by observation that
-- substitution (i.e., cut) can be defined.
--
-- A small-step evaluation semantics is defined after the definition of cut.
--
-- Progress is proved w.r.t. the evaluation semantics.
--
-- Some ideas for extensions or homeworks are given at the end.
--
-- A few helper definitions are required.
-- * Basic Agda constructions (like booleans, products, dependent sums,
--   and lists) are defined first in a Prelude module which is
--   immediately opened.
-- * Binders (x : τ ∈ Γ) are proofs that the element τ is contained in
--   the list of types Γ. Helper functions for weakening and
--   introducing variables into contexts which are reusable are
--   defined in the Prelude. Helpers for weakening terms are defined
--   below. Some of the non-general helpers (like cut[∈]) could be
--   defined in a generic way to be reusable, but I decided against
--   this to keep things simple.

module Darais where

open import Agda.Primitive using (_⊔_)

module Prelude where

  infixr 3 ∃𝑠𝑡
  infixl 5 _∨_
  infix 10 _∈_
  infixl 15 _⧺_
  infixl 15 _⊟_
  infixl 15 _∾_
  infixr 20 _∷_

  data 𝔹 : Set where
    T : 𝔹
    F : 𝔹

  data _∨_ {ℓ₁ ℓ₂} (A : Set ℓ₁) (B : Set ℓ₂) : Set (ℓ₁ ⊔ ℓ₂) where
    Inl : A → A ∨ B
    Inr : B → A ∨ B

  syntax ∃𝑠𝑡 A (λ x → B) = ∃ x ⦂ A 𝑠𝑡 B
  data ∃𝑠𝑡 {ℓ₁ ℓ₂} (A : Set ℓ₁) (B : A → Set ℓ₂) : Set (ℓ₁ ⊔ ℓ₂) where
    ⟨∃_,_⟩ : ∀ (x : A) → B x → ∃ x ⦂ A 𝑠𝑡 B x

  data ⟬_⟭ {ℓ} (A : Set ℓ) : Set ℓ where
    [] : ⟬ A ⟭
    _∷_ : A → ⟬ A ⟭ → ⟬ A ⟭

  _⧺_ : ∀ {ℓ} {A : Set ℓ} → ⟬ A ⟭ → ⟬ A ⟭ → ⟬ A ⟭
  [] ⧺ ys = ys
  x ∷ xs ⧺ ys = x ∷ (xs ⧺ ys)

  _∾_ : ∀ {ℓ} {A : Set ℓ} → ⟬ A ⟭ → ⟬ A ⟭ → ⟬ A ⟭
  [] ∾ ys = ys
  (x ∷ xs) ∾ ys = xs ∾ x ∷ ys

  data _∈_ {ℓ} {A : Set ℓ} (x : A) : ∀ (xs : ⟬ A ⟭) → Set ℓ where
    Z : ∀ {xs} → x ∈ x ∷ xs
    S : ∀ {x′ xs} → x ∈ xs → x ∈ x′ ∷ xs

  _⊟_ : ∀ {ℓ} {A : Set ℓ} (xs : ⟬ A ⟭) {x} → x ∈ xs → ⟬ A ⟭
  x ∷ xs ⊟ Z = xs
  x ∷ xs ⊟ S ε = x ∷ (xs ⊟ ε)

  wk[∈] : ∀ {ℓ} {A : Set ℓ} {xs : ⟬ A ⟭} {x : A} xs′ → x ∈ xs → x ∈ xs′ ∾ xs
  wk[∈] [] x = x
  wk[∈] (x′ ∷ xs) x = wk[∈] xs (S x)

  i[∈][_] : ∀ {ℓ} {A : Set ℓ} {xs : ⟬ A ⟭} {x x′ : A} (ε′ : x′ ∈ xs) → x ∈ xs ⊟ ε′ → x ∈ xs
  i[∈][ Z ] x = S x
  i[∈][ S ε′ ] Z = Z
  i[∈][ S ε′ ] (S x) = S (i[∈][ ε′ ] x)

open Prelude

-- ============================ --
-- Simply Typed Lambda Calculus --
-- ============================ --

-- A dependent de Bruijn encoding
-- Or, the dynamic semantics of natural deduction as seen through Curry-Howard

-- types --

data type : Set where
  ⟨𝔹⟩ : type
  _⟨→⟩_ : type → type → type

-- terms --

infix 10 _⊢_
data _⊢_ : ∀ (Γ : ⟬ type ⟭) (τ : type) → Set where
  ⟨𝔹⟩ : ∀ {Γ}
    (b : 𝔹)
    → Γ ⊢ ⟨𝔹⟩
  ⟨if⟩_❴_❵❴_❵ : ∀ {Γ τ}
    (e₁ : Γ ⊢ ⟨𝔹⟩)
    (e₂ : Γ ⊢ τ)
    (e₃ : Γ ⊢ τ)
    → Γ ⊢ τ
  Var : ∀ {Γ τ}
    (x : τ ∈ Γ)
    → Γ ⊢ τ
  ⟨λ⟩ : ∀ {Γ τ₁ τ₂}
    (e : τ₁ ∷ Γ ⊢ τ₂)
    → Γ ⊢ τ₁ ⟨→⟩ τ₂
  _⟨⋅⟩_ : ∀ {Γ τ₁ τ₂}
    (e₁ : Γ ⊢ τ₁ ⟨→⟩ τ₂)
    (e₂ : Γ ⊢ τ₁)
    → Γ ⊢ τ₂

-- introducing a new variable to the context --

i[⊢][_] : ∀ {Γ τ τ′} (x′ : τ′ ∈ Γ) → Γ ⊟ x′ ⊢ τ → Γ ⊢ τ
i[⊢][ x′ ] (⟨𝔹⟩ b) = ⟨𝔹⟩ b
i[⊢][ x′ ] ⟨if⟩ e₁ ❴ e₂ ❵❴ e₃ ❵ = ⟨if⟩ i[⊢][ x′ ] e₁ ❴ i[⊢][ x′ ] e₂ ❵❴ i[⊢][ x′ ] e₃ ❵
i[⊢][ x′ ] (Var x) = Var (i[∈][ x′ ] x)
i[⊢][ x′ ] (⟨λ⟩ e) = ⟨λ⟩ (i[⊢][ S x′ ] e)
i[⊢][ x′ ] (e₁ ⟨⋅⟩ e₂) = i[⊢][ x′ ] e₁ ⟨⋅⟩ i[⊢][ x′ ] e₂

i[⊢] : ∀ {Γ τ τ′} → Γ ⊢ τ → τ′ ∷ Γ ⊢ τ
i[⊢] = i[⊢][ Z ]

-- substitution for variables --

cut[∈]<_>[_] : ∀ {Γ τ₁ τ₂} (x : τ₁ ∈ Γ) Γ′ → Γ′ ∾ (Γ ⊟ x) ⊢ τ₁ → τ₂ ∈ Γ → Γ′ ∾ (Γ ⊟ x) ⊢ τ₂
cut[∈]< Z >[ Γ′ ] e Z = e
cut[∈]< Z >[ Γ′ ] e (S y) = Var (wk[∈] Γ′ y)
cut[∈]< S x′ >[ Γ′ ] e Z = Var (wk[∈] Γ′ Z)
cut[∈]< S x′ >[ Γ′ ] e (S x) = cut[∈]< x′ >[ _ ∷ Γ′ ] e x

cut[∈]<_> : ∀ {Γ τ₁ τ₂} (x : τ₁ ∈ Γ) → Γ ⊟ x ⊢ τ₁ → τ₂ ∈ Γ → Γ ⊟ x ⊢ τ₂
cut[∈]< x′ > = cut[∈]< x′ >[ [] ]

-- substitution for terms --

cut[⊢][_] : ∀ {Γ τ₁ τ₂} (x : τ₁ ∈ Γ) → Γ ⊟ x ⊢ τ₁ → Γ ⊢ τ₂ → Γ ⊟ x ⊢ τ₂
cut[⊢][ x′ ] e′ (⟨𝔹⟩ b) = ⟨𝔹⟩ b
cut[⊢][ x′ ] e′ ⟨if⟩ e₁ ❴ e₂ ❵❴ e₃ ❵ = ⟨if⟩ cut[⊢][ x′ ] e′ e₁ ❴ cut[⊢][ x′ ] e′ e₂ ❵❴ cut[⊢][ x′ ] e′ e₃ ❵
cut[⊢][ x′ ] e′ (Var x) = cut[∈]< x′ > e′ x
cut[⊢][ x′ ] e′ (⟨λ⟩ e) = ⟨λ⟩ (cut[⊢][ S x′ ] (i[⊢] e′) e)
cut[⊢][ x′ ] e′ (e₁ ⟨⋅⟩ e₂) = cut[⊢][ x′ ] e′ e₁ ⟨⋅⟩ cut[⊢][ x′ ] e′ e₂

cut[⊢] : ∀ {Γ τ₁ τ₂} → Γ ⊢ τ₁ → τ₁ ∷ Γ ⊢ τ₂ → Γ ⊢ τ₂
cut[⊢] = cut[⊢][ Z ]

-- values --

data value {Γ} : ∀ {τ} → Γ ⊢ τ → Set where
  ⟨𝔹⟩ : ∀ b → value (⟨𝔹⟩ b)
  ⟨λ⟩ : ∀ {τ τ′} (e : τ′ ∷ Γ ⊢ τ) → value (⟨λ⟩ e)

-- CBV evaluation for terms --
-- (borrowing some notation and style from Wadler: https://wenkokke.github.io/sf/Stlc)

infix 10 _↝_
data _↝_ {Γ τ} : Γ ⊢ τ → Γ ⊢ τ → Set where
  ξ⋅₁ : ∀ {τ′} {e₁ e₁′ : Γ ⊢ τ′ ⟨→⟩ τ} {e₂ : Γ ⊢ τ′}
    → e₁ ↝ e₁′
    → e₁ ⟨⋅⟩ e₂ ↝ e₁′ ⟨⋅⟩ e₂
  ξ⋅₂ : ∀ {τ′} {e₁ : Γ ⊢ τ′ ⟨→⟩ τ} {e₂ e₂′ : Γ ⊢ τ′}
    → value e₁
    → e₂ ↝ e₂′
    → e₁ ⟨⋅⟩ e₂ ↝ e₁ ⟨⋅⟩ e₂′
  βλ : ∀ {τ′} {e₁ : τ′ ∷ Γ ⊢ τ} {e₂ : Γ ⊢ τ′}
    → value e₂
    → ⟨λ⟩ e₁ ⟨⋅⟩ e₂ ↝ cut[⊢] e₂ e₁
  ξif : ∀ {e₁ e₁′ : Γ ⊢ ⟨𝔹⟩} {e₂ e₃ : Γ ⊢ τ}
    → e₁ ↝ e₁′
    → ⟨if⟩ e₁ ❴ e₂ ❵❴ e₃ ❵ ↝ ⟨if⟩ e₁′ ❴ e₂ ❵❴ e₃ ❵
  ξif-T : ∀ {e₂ e₃ : Γ ⊢ τ}
    → ⟨if⟩ ⟨𝔹⟩ T ❴ e₂ ❵❴ e₃ ❵ ↝ e₂
  ξif-F : ∀ {e₂ e₃ : Γ ⊢ τ}
    → ⟨if⟩ ⟨𝔹⟩ F ❴ e₂ ❵❴ e₃ ❵ ↝ e₃

-- progress --

progress : ∀ {τ} (e : [] ⊢ τ) → value e ∨ (∃ e′ ⦂ [] ⊢ τ 𝑠𝑡 e ↝ e′)
progress (⟨𝔹⟩ b) = Inl (⟨𝔹⟩ b)
progress ⟨if⟩ e ❴ e₁ ❵❴ e₂ ❵ with progress e
… | Inl (⟨𝔹⟩ T) = Inr ⟨∃ e₁ , ξif-T ⟩
… | Inl (⟨𝔹⟩ F) = Inr ⟨∃ e₂ , ξif-F ⟩
… | Inr ⟨∃ e′ , ε ⟩ = Inr ⟨∃ ⟨if⟩ e′ ❴ e₁ ❵❴ e₂ ❵ , ξif ε ⟩
progress (Var ())
progress (⟨λ⟩ e) = Inl (⟨λ⟩ e)
progress (e₁ ⟨⋅⟩ e₂) with progress e₁
… | Inr ⟨∃ e₁′ , ε ⟩ = Inr ⟨∃ e₁′ ⟨⋅⟩ e₂ , ξ⋅₁ ε ⟩
… | Inl (⟨λ⟩ e) with progress e₂
… | Inl x = Inr ⟨∃ cut[⊢] e₂ e , βλ x ⟩
… | Inr ⟨∃ e₂′ , ε ⟩ = Inr ⟨∃ e₁ ⟨⋅⟩ e₂′ , ξ⋅₂ (⟨λ⟩ e) ε ⟩

-- Some ideas for possible extensions or homework assignments
-- 1. A. Write a conversion from the dependent de Bruijn encoding (e : Γ ⊢ τ)
--       to the untyped lambda calculus (e : term).
--    B. Prove that the image of this conversion is well typed.
--    C. Write a conversion from well-typed untyped lambda calculus
--       terms ([e : term] and [ε : (Γ ⊢ e ⦂ τ)] into the dependent de
--       Bruijn encoding (e : Γ ⊢ τ)
-- 2. A. Write a predicate analogous to 'value' for strongly reduced
--       terms (reduction under lambda)
--    B. Prove "strong" progress: A term is either fully beta-reduced
--       (including under lambda) or it can take a step
-- 3. Relate this semantics to a big-step semantics.
-- 4. Prove strong normalization.
-- 5. Relate this semantics to a definitional interpreter into Agda's Set.

error: pathspec 'src/extra/Darais.agda' did not match any file(s) known to git


Added note on ordinals.

Added note on ordinals.

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

From: Hancock (2008). (Ordinal-theoretic) proof theory.

module Ordinals where

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

data Ω : Set where
  zero : Ω
  succ : Ω → Ω
  limN : (ℕ → Ω) → Ω

inj : ℕ → Ω
inj zero     = zero
inj (succ n) = succ (inj n)

ω : Ω
ω = limN (λ n → inj n)

ω+1 : Ω
ω+1 = succ ω

data Ω₂ : Set where
  zero : Ω₂
  succ : Ω₂ → Ω₂
  limN : (ℕ → Ω₂) → Ω₂
  limΩ : (Ω → Ω₂) → Ω₂

inj₁ : Ω → Ω₂
inj₁ zero     = zero
inj₁ (succ o) = succ (inj₁ o)
inj₁ (limN f) = limN (λ n → inj₁ (f n))

ω₁ : Ω₂
ω₁ = limΩ (λ o → inj₁ o)

error: pathspec 'notes/Ordinals.agda' did not match any file(s) known to git


proof sketch of otp-lem

proof sketch of otp-lem

module otp-lem where

open import Level
open import Algebra.FunctionProperties
open import Data.Product

open import Function using (_∘_ ; flip)
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Relation.Binary.PropositionalEquality.NP
open import Search.Type
open import Search.Sum

record Group (G : Set) : Set where
  field
    _∙_ : G → G → G
    ε   : G
    -_  : G → G

  -- laws
  field
    assoc : Associative _≡_ _∙_
    identity : Identity _≡_ ε _∙_
    inverse  : Inverse _≡_ ε -_ _∙_

GroupHomomorphism : ∀ {A B : Set} → Group A → Group B →(A → B) → Set
GroupHomomorphism GA GB f = ∀ x y → f (x + y) ≡ f x * f y
  where
    open Group GA renaming (_∙_ to _+_)
    open Group GB renaming (_∙_ to _*_)

module _ {A B}(GA : Group A)(GB : Group B)(f : A → B)(searchA : Search zero A)(f-homo : GroupHomomorphism GA GB f)([f] : B → A)(f-sur : ∀ b → f ([f] b) ≡ b)
              (sui : ∀ k → StableUnder searchA (flip (Group._∙_ GA) k))(search-ext : SearchExt searchA) where
  open Group GA using (-_) renaming (_∙_ to _+_ ; ε to 0g)
  open Group GB using ()   renaming (_∙_ to _*_ ; ε to 1g ; -_ to 1/_)

  help : ∀ x y → x ≡ (x * y) * 1/ y
  help x y = x
           ≡⟨ sym (proj₂ identity x) ⟩
             x * 1g
           ≡⟨ cong (_*_ x) (sym (proj₂ inverse y)) ⟩
             x * (y * 1/ y)
           ≡⟨ sym (assoc x y (1/ y)) ⟩
             (x * y) * (1/ y)
           ∎
    where open ≡-Reasoning
          open Group GB

  unique-1g : ∀ x y → x * y ≡ y → x ≡ 1g
  unique-1g x y eq = x
                   ≡⟨ help x y ⟩
                     (x * y) * 1/ y
                   ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                     y * 1/ y
                   ≡⟨ proj₂ inverse y ⟩
                     1g
                   ∎
    where open ≡-Reasoning
          open Group GB

  unique-/ : ∀ x y → x * y ≡ 1g → x ≡ 1/ y
  unique-/ x y eq = x
                  ≡⟨ help x y ⟩
                    (x * y) * 1/ y
                  ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                    1g * 1/ y
                  ≡⟨ proj₁ identity (1/ y) ⟩
                    1/ y
                  ∎
    where open ≡-Reasoning
          open Group GB

  f-pres-ε : f 0g ≡ 1g
  f-pres-ε = unique-1g (f 0g) (f 0g) part
    where open ≡-Reasoning
          open Group GA
          part = f 0g * f 0g
               ≡⟨ sym (f-homo 0g 0g) ⟩
                 f (0g + 0g)
               ≡⟨ cong f (proj₁ identity 0g) ⟩
                 f 0g
               ∎

  f-pres-inv : ∀ x → f (- x) ≡ 1/ f x
  f-pres-inv x = unique-/ (f (- x)) (f x) part
    where open ≡-Reasoning
          open Group GA hiding (-_)
          part = f (- x) * f x
               ≡⟨ sym (f-homo (- x) x) ⟩
                 f (- x + x)
               ≡⟨ cong f (proj₁ inverse x) ⟩
                 f 0g
               ≡⟨ f-pres-ε ⟩
                 1g
               ∎

  -- this proof isn't actually any hard..
  thm : ∀ {X}(op : X → X → X)(O : B → X) m₀ m₁ → searchA op (λ x → O (f x * m₀)) ≡ searchA op (λ x → O (f x * m₁))
  thm op O m₀ m₁ = searchA op (λ x → O (f x * m₀))
                 ≡⟨ sui (- [f] m₀) op (λ x → O (f x * m₀)) ⟩
                   searchA op (λ x → O (f (x + - [f] m₀)  * m₀))
                 ≡⟨ search-ext op (λ x → cong (λ p → O (p * m₀)) (f-homo x (- [f] m₀))) ⟩
                   searchA op (λ x → O ((f x * f(- [f] m₀))  * m₀))
                 ≡⟨ cong (λ p → searchA op (λ x → O ((f x * p) * m₀))) (f-pres-inv ([f] m₀)) ⟩
                   searchA op (λ x → O ((f x * 1/ f([f] m₀))  * m₀))
                 ≡⟨ search-ext op (λ x → cong O (Group.assoc GB (f x) (1/ f ([f] m₀)) m₀)) ⟩
                   searchA op (λ x → O (f x * (1/ f([f] m₀)  * m₀)))
                 ≡⟨ cong (λ p → searchA op (λ x → O (f x * (1/ p * m₀)))) (f-sur m₀) ⟩
                   searchA op (λ x → O (f x * (1/ m₀ * m₀)))
                 ≡⟨ cong (λ p → searchA op (λ x → O (f x * p))) (proj₁ (Group.inverse GB) m₀) ⟩
                   searchA op (λ x → O (f x * 1g))
                 ≡⟨ search-ext op (λ x → cong O (proj₂ (Group.identity GB) (f x))) ⟩
                   searchA op (λ x → O (f x ))
                 ≡⟨ sui ([f] m₁) op (λ x → O (f x)) ⟩
                   searchA op (λ x → O (f (x + [f] m₁)))
                 ≡⟨ search-ext op (λ x → cong O (f-homo x ([f] m₁))) ⟩
                   searchA op (λ x → O (f x * f ([f] m₁)))
                 ≡⟨ cong (λ p → searchA op (λ x → O (f x * p))) (f-sur m₁) ⟩
                   searchA op (λ x → O (f x * m₁))
                 ∎
    where
      open ≡-Reasoning

error: pathspec 'otp-lem.agda' did not match any file(s) known to git


Initial commit: Embed validity proofs in Δ-terms

Reason: Deal with nonfull abstraction by removing elements from
the domain of Δ-types.

Checkpoint: Untangle syntax and semantics of Δ-terms via de-facto
existential type that hides the semantics function in the
definition of Δ-terms.

Old-commit-hash: 598647f579bd017f335f1ce5f36414a6442dc4e9

{-
The goal of this file is to make the domain of Δ types smaller
so as to be nearer to full abstraction and hopefully close
enough for the purpose of having explicit nil changes.
-}

module TaggedDeltaTypes where

open import Data.NatBag renaming
  (map to mapBag ; empty to emptyBag ; update to updateBag)
open import Relation.Binary.PropositionalEquality
open import Data.Nat
open import Data.Unit using (⊤ ; tt)
import Data.Integer as ℤ
import Data.Product as Product
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)
import Level

-- Postulates: Extensionality and bag properties (#55)
postulate extensionality : Extensionality Level.zero Level.zero
--
-- open import Data.NatBag.Properties
postulate b\\b=∅ : ∀ {{b : Bag}} → b \\ b ≡ emptyBag
postulate b++∅=b : ∀ {{b : Bag}} → b ++ emptyBag ≡ b
postulate ∅++b=b : ∀ {{b : Bag}} → emptyBag ++ b ≡ b
postulate b++[d\\b]=d : ∀ {b d} → b ++ (d \\ b) ≡ d
postulate [b++d]\\b=d : ∀ {b d} → (b ++ d) \\ b ≡ d
postulate
  [a++b]\\[c++d]=[a\\c]++[b\\d] : ∀ {a b c d} →
    (a ++ b) \\ (c ++ d) ≡ (a \\ c) ++ (b \\ d)
postulate
  [a\\b]\\[c\\d]=[a\\c]\\[b\\d] : ∀ {a b c d} →
    (a \\ b) \\ (c \\ d) ≡ (a \\ c) \\ (b \\ d)

------------------------
-- Syntax of programs --
------------------------

data Type : Set where
  nats : Type
  bags : Type
  _⇒_ : (τ₁ τ₂ : Type) → Type

infixr 5 _⇒_

data Context : Set where
  ∅ : Context
  _•_ : (τ : Type) (Γ : Context) → Context

infixr 9 _•_

data Var : Context → Type → Set where
  this : ∀ {τ Γ} → Var (τ • Γ) τ
  that : ∀ {τ τ′ Γ} → (x : Var Γ τ) → Var (τ′ • Γ) τ

data Term : Context -> Type -> Set where

  nat : ∀ {Γ} → (n : ℕ) → Term Γ nats
  bag : ∀ {Γ} → (b : Bag) → Term Γ bags

  var : ∀ {τ Γ} → (x : Var Γ τ) → Term Γ τ
  abs : ∀ {τ₁ τ₂ Γ} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {τ₁ τ₂ Γ} → (s : Term Γ (τ₁ ⇒ τ₂)) (t : Term Γ τ₁)
                   → Term Γ τ₂

  add : ∀ {Γ} → (s : Term Γ nats) → (t : Term Γ nats) → Term Γ nats
  map : ∀ {Γ} → (f : Term Γ (nats ⇒ nats)) → (b : Term Γ bags) → Term Γ bags

infix 8 _≼_

data _≼_ : (Γ₁ Γ₂ : Context) → Set where
  ∅≼∅ : ∅ ≼ ∅
  keep_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → τ • Γ₁ ≼ τ • Γ₂
  drop_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → Γ₁ ≼ τ • Γ₂

Γ≼Γ : ∀ {Γ} → Γ ≼ Γ
Γ≼Γ {∅} = ∅≼∅
Γ≼Γ {τ • Γ} = keep τ • Γ≼Γ {Γ}

weakenVar : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
weakenVar ∅≼∅ x = x
weakenVar (keep τ₁ • subctx) this = this
weakenVar (keep τ₁ • subctx) (that y) = that (weakenVar subctx y)
weakenVar (drop τ₁ • subctx) x = that (weakenVar subctx x)

weaken : ∀ {Γ₁ Γ₂ τ} → (subctx : Γ₁ ≼ Γ₂) → Term Γ₁ τ → Term Γ₂ τ
weaken subctx (abs {τ} t) = abs (weaken (keep τ • subctx) t)
weaken subctx (app t₁ t₂) = app (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (var x) = var (weakenVar subctx x)
weaken subctx (nat x) = nat x
weaken subctx (bag b) = bag b
weaken subctx (add t₁ t₂) = add (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (map f b) = map (weaken subctx f) (weaken subctx b)

---------------------------
-- Semantics of programs --
---------------------------

record Meaning (Syntax : Set) {ℓ : Level.Level} : Set (Level.suc ℓ) where
  constructor
    meaning
  field
    {Semantics} : Set ℓ
    ⟨_⟩⟦_⟧ : Syntax → Semantics

open Meaning {{...}} public
  renaming (⟨_⟩⟦_⟧ to ⟦_⟧)

⟦_⟧Type : Type -> Set
⟦ nats ⟧Type = ℕ
⟦ bags ⟧Type = Bag
⟦ τ₁ ⇒ τ₂ ⟧Type = ⟦ τ₁ ⟧Type → ⟦ τ₂ ⟧Type

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

data Bind A B : Set where
  _•_ : (v : A) (ρ : B) → Bind A B

⟦_⟧Context : Context → Set
⟦ ∅ ⟧Context = EmptySet
⟦ τ • Γ ⟧Context = Bind ⟦ τ ⟧ ⟦ Γ ⟧Context

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

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

meaningOfVar : ∀ {Γ τ} → Meaning (Var Γ τ)
meaningOfVar = meaning ⟦_⟧Var

⟦_⟧≼ : ∀ {Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → ⟦ Γ₂ ⟧ → ⟦ Γ₁ ⟧
⟦ ∅≼∅ ⟧≼ ∅ = ∅
⟦ keep τ • subctx ⟧≼ (v • ρ) = v • ⟦ subctx ⟧≼ ρ
⟦ drop τ • subctx ⟧≼ (v • ρ) = ⟦ subctx ⟧≼ ρ

meaningOf≼ : ∀ {Γ₁ Γ₂} → Meaning (Γ₁ ≼ Γ₂)
meaningOf≼ = meaning ⟦_⟧≼

identity-weakening : ∀ {Γ} {ρ : ⟦ Γ ⟧} → ⟦ Γ≼Γ {Γ} ⟧ ρ ≡ ρ
identity-weakening {∅} {∅} = refl
identity-weakening {τ • Γ} {v • ρ} =
  cong₂ _•_ {x = v} refl (identity-weakening {Γ} {ρ})

weakenVar-sound : ∀ {Γ₁ Γ₂ τ} (subctx : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weakenVar subctx x ⟧ ρ ≡ ⟦ x ⟧ (⟦ subctx ⟧ ρ)
weakenVar-sound ∅≼∅ () ρ
weakenVar-sound (keep τ • subctx) this (v • ρ) = refl
weakenVar-sound (keep τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx x ρ
weakenVar-sound (drop τ • subctx) this (v • ρ) =
  weakenVar-sound subctx this ρ
weakenVar-sound (drop τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx (that x) ρ

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
⟦ nat n ⟧Term ρ = n
⟦ bag b ⟧Term ρ = b
⟦ add m n ⟧Term ρ = ⟦ m ⟧Term ρ + ⟦ n ⟧Term ρ
⟦ map f b ⟧Term ρ = mapBag (⟦ f ⟧Term ρ) (⟦ b ⟧Term ρ)

meaningOfTerm : ∀ {Γ τ} → Meaning (Term Γ τ)
meaningOfTerm = meaning ⟦_⟧Term

_⟨$⟩_ : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
_⟨$⟩_ = cong₂ (λ x y → x y)

-- infix 0 $ in Haskell
infixl 0 _⟨$⟩_

weaken-sound : ∀ {Γ₁ Γ₂ τ} {subctx : Γ₁ ≼ Γ₂} (t : Term Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken subctx t ⟧ ρ ≡ ⟦ t ⟧ (⟦ subctx ⟧ ρ)
weaken-sound (abs t) ρ = extensionality (λ v → weaken-sound t (v • ρ))
weaken-sound (app t₁ t₂) ρ = weaken-sound t₁ ρ ⟨$⟩ weaken-sound t₂ ρ
weaken-sound {subctx = subctx} (var x) ρ = weakenVar-sound subctx x ρ
weaken-sound (nat n) ρ = refl

weaken-sound (bag b) ρ = refl
weaken-sound (add m n) ρ = cong₂ _+_ (weaken-sound m ρ) (weaken-sound n ρ)
weaken-sound (map f b) ρ =
  cong₂ mapBag (weaken-sound f ρ) (weaken-sound b ρ)

----------------------------------------------------------
-- Syntax and semantics of changes (they are entangled) --
----------------------------------------------------------

data Δ-Type : Set where
  Δ : (τ : Type) → Δ-Type

data Δ-Context : Set where
  Δ : (Γ : Context) → Δ-Context

Env : Context → Set
Env Γ = ⟦ Γ ⟧Context

private data Δ-Term : Δ-Context → Δ-Type → Set

-- Syntax of Δ-Types
-- ...   is mutually recursive with semantics of Δ-Terms,
-- (because it embeds validity proofs)
-- which is mutually recursive with validity and Δ-environments,
-- which is mutually recursive with ⊕,
-- which is mutually recursive with ⊝ and R[v,v⊝v],
-- which is mutually recursive with v⊕[u⊝v]=v, et cetera.
⟦_⟧Δτ : Δ-Type → Set
Δ-Env : Context → Set
private
  ⟦_⟧Δ : ∀ {τ : Type} {Γ : Context}
    → Δ-Term (Δ Γ) (Δ τ) → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
_⊕_ : ∀ {τ : Type} → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ → ⟦ τ ⟧
_⊝_ : ∀ {τ : Type} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ
valid : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ → Set
R[v,u⊝v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)
v⊕[u⊝v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊕ (u ⊝ v) ≡ u
ignore : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → ⟦ Γ ⟧
update : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → ⟦ Γ ⟧

infixl 6 _⊕_ _⊝_ -- as with + - in GHC.Num

abstract
 data Δ-Term where
  -- changes to numbers are replacement pairs
  Δnat : ∀ {Γ} → (old : ℕ) → (new : ℕ) → Δ-Term (Δ Γ) (Δ nats)
  -- changes to bags are bags
  Δbag : ∀ {Γ} → (db : Bag) → Δ-Term (Δ Γ) (Δ bags)
  -- changes to variables are variables
  Δvar : ∀ {τ Γ} → (x : Var Γ τ) → Δ-Term (Δ Γ) (Δ τ)
  -- changes to abstractions are binders of x and dx
  Δabs : ∀ {τ₁ τ₂ Γ} → (t : Δ-Term (Δ (τ₁ • Γ)) (Δ τ₂)) →
         Δ-Term (Δ Γ) (Δ (τ₁ ⇒ τ₂))
  -- changes to applications are applications of a value and a change
  Δapp : ∀ {τ₁ τ₂ Γ} →(ds : Δ-Term (Δ Γ) (Δ (τ₁ ⇒ τ₂)))
                    → ( t :   Term    Γ      τ₁)
                    → (dt : Δ-Term (Δ Γ) (Δ  τ₁))
                    → (R[t,dt] : {ρ : Δ-Env Γ} → -- 'Tis but a proof.
                                 valid (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ)) →
         Δ-Term (Δ Γ) (Δ τ₂)
  -- changes to addition are changes to their components
  Δadd : ∀ {Γ} → (ds : Δ-Term (Δ Γ) (Δ nats))
               → (dt : Δ-Term (Δ Γ) (Δ nats)) →
         Δ-Term (Δ Γ) (Δ nats)
  -- There are two kinds of changes to maps:
  -- 0. recomputation,
  -- 1. mapping over changes,
  -- the latter used only with some form of isNil available.
  Δmap₀ : ∀ {Γ} → ( f :   Term    Γ     (nats ⇒ nats))
                → (df : Δ-Term (Δ Γ) (Δ (nats ⇒ nats)))
                → ( b :   Term    Γ     bags)
                → (db : Δ-Term (Δ Γ) (Δ bags))
          → Δ-Term (Δ Γ) (Δ bags)
  Δmap₁ : ∀ {Γ} → ( f :   Term    Γ     (nats ⇒ nats))
                → (db : Δ-Term (Δ Γ) (Δ bags))
          → Δ-Term (Δ Γ) (Δ bags)

-- ⟦_⟧Δτ : Δ-Type → Set
⟦ Δ nats ⟧Δτ = ℕ × ℕ
⟦ Δ bags ⟧Δτ = Bag
⟦ Δ (τ₁ ⇒ τ₂) ⟧Δτ =
  (v : ⟦ τ₁ ⟧) → (dv : ⟦ Δ τ₁ ⟧Δτ) → valid v dv → ⟦ Δ τ₂ ⟧Δτ

meaning-Δτ : Meaning Δ-Type
meaning-Δτ = meaning ⟦_⟧Δτ

_⊕_ {nats}   n dn = proj₂ dn
_⊕_ {bags}   b db = b ++ db
_⊕_ {τ₁ ⇒ τ₂} f df = λ v → f v ⊕ df v (v ⊝ v) R[v,u⊝v]

_⊝_ {nats}   m n = (n , m)
_⊝_ {bags}   b d = b \\ d
_⊝_ {τ₁ ⇒ τ₂} f g = λ v dv R[v,dv] → f (v ⊕ dv) ⊝ g v

-- valid : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
valid {nats} n dn = n ≡ proj₁ dn
valid {bags} b db = ⊤
valid {τ₁ ⇒ τ₂} f df =
  ∀ (v : ⟦ τ₁ ⟧) (dv : ⟦ Δ τ₁ ⟧Δτ) (R[v,dv] : valid v dv)
  → valid (f v) (df v dv R[v,dv])
  × (f ⊕ df) (v ⊕ dv) ≡ f v ⊕ df v dv R[v,dv]

eq1 : ∀ {τ₁ τ₂ : Type} {f : ⟦ τ₁ ⇒ τ₂ ⟧} {df} {x : ⟦ τ₁ ⟧} {dx} →
      valid f df → (R[x,dx] : valid x dx) →
      (f ⊕ df) (x ⊕ dx) ≡ f x ⊕ df x dx R[x,dx]

eq1 R[f,df] R[x,dx] = proj₂ (R[f,df] _ _ R[x,dx])

v⊕[u⊝v]=u {nats}   {u} {v} = refl
v⊕[u⊝v]=u {bags}   {u} {v} = b++[d\\b]=d {v} {u}
v⊕[u⊝v]=u {τ₁ ⇒ τ₂} {u} {v} = extensionality (λ w →
  begin
    (v ⊕ (u ⊝ v)) w
  ≡⟨ refl ⟩ -- for clarity
    v w ⊕ (u (w ⊕ (w ⊝ w)) ⊝ v w)
  ≡⟨ cong (λ hole → v w ⊕ (u hole ⊝ v w)) v⊕[u⊝v]=u ⟩
    v w ⊕ (u w ⊝ v w)
  ≡⟨ v⊕[u⊝v]=u ⟩
    u w
  ∎) where open ≡-Reasoning

R[v,u⊝v] {nats} {u} {v} = refl
R[v,u⊝v] {bags} {u} {v} = tt
R[v,u⊝v] {τ₁ ⇒ τ₂} {u} {v} = λ w dw R[w,dw] →
  let
    w′ = w ⊕ dw
  in
    R[v,u⊝v] -- NOT a self recursion: implicit arguments are different.
    ,
    (begin
      (v ⊕ (u ⊝ v)) w′
    ≡⟨ cong (λ hole → hole w′) (v⊕[u⊝v]=u {_} {u} {v}) ⟩
      u w′
    ≡⟨ sym (v⊕[u⊝v]=u {_} {u w′} {v w}) ⟩
      v w ⊕ (u ⊝ v) w dw R[w,dw]
    ∎) where open ≡-Reasoning

record Quadruple
  (A : Set) (B : A → Set) (C : (a : A) → B a → Set)
  (D : (a : A) → (b : B a) → (c : C a b) → Set): Set where
  constructor cons
  field
    car    : A
    cadr   : B car
    caddr  : C car cadr
    cadddr : D car cadr caddr

open Quadruple public

-- The type of environments ensures their consistency.
-- Δ-Env : Context → Set
Δ-Env ∅ = EmptySet
Δ-Env (τ • Γ) = Quadruple
  ⟦ τ ⟧
  (λ v → ⟦ Δ τ ⟧Δτ)
  (λ v dv → valid v dv)
  (λ v dv R[v,dv] → Δ-Env Γ)

-- ignore : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → Env Γ
ignore {∅} ρ = ∅
ignore {τ • Γ} (cons v dv R[v,dv] ρ) = v • ignore ρ

-- update : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → Env Γ
update {∅} ρ = ∅
update {τ • Γ} (cons v dv R[v,dv] ρ) = (v ⊕ dv) • update ρ

⟦_⟧ΔVar : ∀ {τ Γ} → Var Γ τ → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
⟦ this   ⟧ΔVar (cons v dv R[v,dv] ρ) = dv
⟦ that x ⟧ΔVar (cons v dv R[v,dv] ρ) = ⟦ x ⟧ΔVar ρ

-- ⟦_⟧ΔVar is not put into the Meaning type class
-- because its argument is identical to that of ⟦_⟧Var.

-- ⟦_⟧Δ : ∀ {τ Γ} → Δ-Term (Δ Γ) (Δ τ) → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
abstract
 ⟦ Δnat old new ⟧Δ ρ = (old , new)
 ⟦ Δbag db ⟧Δ ρ = db
 ⟦ Δvar x ⟧Δ ρ = ⟦ x ⟧ΔVar ρ
 ⟦ Δabs t ⟧Δ ρ = λ v dv R[v,dv] → ⟦ t ⟧Δ (cons v dv R[v,dv] ρ)
 ⟦ Δapp ds t dt R[dt,t] ⟧Δ ρ =
   ⟦ ds ⟧Δ ρ (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ) R[dt,t]
 ⟦ Δadd ds dt ⟧Δ ρ =
   let
     (old-s , new-s) = ⟦ ds ⟧Δ ρ
     (old-t , new-t) = ⟦ dt ⟧Δ ρ
   in
     (old-s + old-t , new-s + new-t)
 ⟦ Δmap₀ f df b db ⟧Δ ρ =
   let
     v  = ⟦ b ⟧ (ignore ρ)
     h  = ⟦ f ⟧ (ignore ρ)
     dv = ⟦ db ⟧Δ ρ
     dh = ⟦ df ⟧Δ ρ
   in
     mapBag (h ⊕ dh) (v ⊕ dv) \\ mapBag h v
 ⟦ Δmap₁ f db ⟧Δ ρ = mapBag (⟦ f ⟧ (ignore ρ)) (⟦ db ⟧Δ ρ)

meaning-ΔTerm : ∀ {τ Γ} → Meaning (Δ-Term (Δ Γ) (Δ τ))
meaning-ΔTerm = meaning ⟦_⟧Δ

--------------------------------------------------------
-- Program transformation and correctness (entangled) --
--------------------------------------------------------

derive : ∀ {τ Γ} → Term Γ τ → Δ-Term (Δ Γ) (Δ τ)

validity : ∀ {τ Γ} {t : Term Γ τ} {ρ : Δ-Env Γ} →
  valid (⟦ t ⟧ (ignore ρ)) (⟦ derive t ⟧ ρ)

-- derive : ∀ {τ Γ} → Term Γ τ → Δ-Term (Δ Γ) (Δ τ)
derive (nat n) = Δnat n n
derive (bag b) = Δbag b
derive (var x) = Δvar x
derive (abs t) = Δabs (derive t)
derive (app s t) = Δapp (derive s) t (derive t) validity
derive (add s t) = Δadd (derive s) (derive t)
derive (map f b) = Δmap₀ f (derive f) b (derive b)

validity-var : ∀ {τ Γ} → (x : Var Γ τ) →
  ∀ {ρ : Δ-Env Γ} → valid (⟦ x ⟧ (ignore ρ)) (⟦ x ⟧ΔVar ρ)

validity-var this {cons v dv R[v,dv] ρ} = R[v,dv]
validity-var (that x) {cons v dv R[v,dv] ρ} = validity-var x

validity {nats} {Γ} {nat n} {ρ} = {!!}

validity {bags} {Γ} {bag b} = {!!}
validity {τ} {Γ} {var x} = {!!}
validity {τ₁ ⇒ τ₂} {Γ} {abs t} = {!!}
validity {τ} {Γ} {app t t₁} = {!!}
validity {nats} {Γ} {add t t₁} = {!!}
validity {bags} {Γ} {map t t₁} = {!!}

error: pathspec 'experimental/TaggedDeltaTypes.agda' did not match any file(s) known to git


no hello3

no hello3

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/nfjinjing/chu2.git/'


models: "algebraic" model for IIR

models: "algebraic" model for IIR

error: RPC failed; HTTP 403 curl 22 The requested URL returned error: 403
fatal: the remote end hung up unexpectedly


Added draft: Comparing equational reasoning.

Ignore-this: a34e9564240c152ee9826930fb0b857d

darcs-hash:20110119161619-3bd4e-8db9a3cb20dd00eca07f42f8e7e0115f97cd378c.gz

------------------------------------------------------------------------------
-- Comparing Ulf and Nils styles for equational reasoning
------------------------------------------------------------------------------

module ComparingEqReasoning where

infix  7 _≡_
infixl 9  _+_

data _≡_ {A : Set}(x : A) : A → Set where
  refl : x ≡ x

trans : {A : Set}{x y z : A} → x ≡ y → y ≡ z → x ≡ z
trans refl refl = refl

postulate
  ℕ               : Set
  zero            : ℕ
  _+_             : ℕ → ℕ → ℕ
  +-comm          : (m n : ℕ) → m + n ≡ n + m
  +-rightIdentity : (n : ℕ) → n + zero ≡ n

infix 7 _≃_

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

module Ulf where
  -- Adapted from the Ulf's thesis (p. 112).

  infix  5 chain>_
  infixl 5 _===_by_
  infix  4 _qed

  chain>_ : (x : ℕ) → x ≃ x
  chain> x = prf refl

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

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

  -- Example
  +-leftIdentity : (n : ℕ) → zero + n ≡ n
  +-leftIdentity n =
    chain> zero + n
       === n + zero by +-comm zero n
       === n        by +-rightIdentity n
    qed

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

  infix  4 begin_
  infixr 5 _≡⟨_⟩_
  infix  5 _∎

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

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

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

  -- Example.
  +-leftIdentity : (n : ℕ) → zero + n ≡ n
  +-leftIdentity n =
    begin
      zero + n ≡⟨ +-comm zero n ⟩
      n + zero ≡⟨ +-rightIdentity n ⟩
      n
    ∎

error: pathspec 'Draft/ComparingEqReasoning.agda' did not match any file(s) known to git


Added draft: Theory T from the paper.

Added draft: Theory T from the paper.

Ignore-this: 38207a8310ffe6760d66da34a4cf8be7

darcs-hash:20110125160655-3bd4e-f62a7cdd9887f5298d9e07fbbae290e3c39a73ac.gz

error: pathspec 'Draft/T.agda' did not match any file(s) known to git


{-# OPTIONS --without-K #-}
open import Function.NP
open import Data.Product.NP using (Σ; _×_; _,_; first)
open import Data.Two hiding (_≟_)
open import Data.Nat hiding (_⊔_)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; _∙_; refl; ap)
open import Function.Extensionality
open import HoTT
open Equivalences

open import Control.Protocol

module Control.Protocol.Sequence where

_>>=_ : (P : Proto) → (Log P → Proto) → Proto
end     >>= Q = Q _
com q P >>= Q = com q λ m → P m >>= λ ms → Q (m , ms)

_>>_ : Proto → Proto → Proto
P >> Q = P >>= λ _ → Q

replicateᴾ : ℕ → Proto → Proto
replicateᴾ 0       P = end
replicateᴾ (suc n) P = P >> replicateᴾ n P

++Log : ∀ (P : Proto){Q : Log P → Proto} (xs : Log P) → Log (Q xs) → Log (P >>= Q)
++Log end       _        ys = ys
++Log (com q P) (x , xs) ys = x , ++Log (P x) xs ys

module _ {{_ : FunExt}} where
    >>=-right-unit : ∀ P → (P >> end) ≡ P
    >>=-right-unit end       = refl
    >>=-right-unit (com q P) = com= refl refl λ m → >>=-right-unit (P m)

    >>=-assoc : ∀ (P : Proto)(Q : Log P → Proto)(R : Log (P >>= Q) → Proto)
                → P >>= (λ x → Q x >>= (λ y → R (++Log P x y))) ≡ ((P >>= Q) >>= R)
    >>=-assoc end       Q R = refl
    >>=-assoc (com q P) Q R = com= refl refl λ m → >>=-assoc (P m) (λ ms → Q (m , ms)) (λ ms → R (m , ms))

    ap->>= : ∀ P {Q₀ Q₁} → (∀ {log} → ⟦ Q₀ log ⟧ ≡ ⟦ Q₁ log ⟧) → ⟦ P >>= Q₀ ⟧ ≡ ⟦ P >>= Q₁ ⟧
    ap->>= end      Q= = Q=
    ap->>= (send P) Q= = Σ=′ _ λ m → ap->>= (P m) Q=
    ap->>= (recv P) Q= = Π=′ _ λ m → ap->>= (P m) Q=

    dual->> : ∀ P Q → dual (P >> Q) ≡ dual P >> dual Q
    dual->> end        Q = refl
    dual->> (com io P) Q = com= refl refl λ m → dual->> (P m) Q

    {- My coe-ap-fu is lacking...
    dual->>= : ∀ P (Q : Log P → Proto) → dual (P >>= Q) ≡ dual P >>= (dual ∘ Q ∘ coe (dual-Log P))
    dual->>= end Q = refl
    dual->>= (com io P) Q = com= refl refl λ m → dual->>= (P m) (Q ∘ _,_ m) ∙ ap (_>>=_ (dual (P m))) (λ= λ ms → ap (λ x → dual (Q x)) (pair= {!!} {!!}))
    -}

    dual-replicateᴾ : ∀ n P → dual (replicateᴾ n P) ≡ replicateᴾ n (dual P)
    dual-replicateᴾ zero    P = refl
    dual-replicateᴾ (suc n) P = dual->> P (replicateᴾ n P) ∙ ap (_>>_ (dual P)) (dual-replicateᴾ n P)

{- An incremental telecom function which makes processes communicate
   during a matching initial protocol. -}
>>=-telecom : (P : Proto){Q : Log P → Proto}{R : Log P → Proto}
            → ⟦ P >>= Q  ⟧
            → ⟦ P >>= R ⊥⟧
            → Σ (Log P) (λ t → ⟦ Q t ⟧ × ⟦ R t ⊥⟧)
>>=-telecom end      p0       p1       = _ , p0 , p1
>>=-telecom (send P) (m , p0) p1       = first (_,_ m) (>>=-telecom (P m) p0 (p1 m))
>>=-telecom (recv P) p0       (m , p1) = first (_,_ m) (>>=-telecom (P m) (p0 m) p1)

>>-telecom : (P : Proto){Q R : Proto}
           → ⟦ P >> Q  ⟧
           → ⟦ P >> R ⊥⟧
           → Log P × ⟦ Q ⟧ × ⟦ R ⊥⟧
>>-telecom P p q = >>=-telecom P p q

error: pathspec 'Control/Protocol/Sequence.agda' did not match any file(s) known to git


+Algebra/Field

+Algebra/Field

module Algebra.Field where

open import Relation.Binary.PropositionalEquality.NP
import Algebra.FunctionProperties.Eq as FP

record IsField {ℓ} (A : Set ℓ) : Set ℓ where
  open FP {ℓ} {A}

  infixl 6 _+_ _−_
  infixl 7 _*_ _/_

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

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

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

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

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

module TermField {a} {A : Set a} (F : IsField A) where
  open IsField 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-Field {b}{B : Set b}(G : IsField B)(default : Decode-Term B) where
    module G = IsField 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

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

error: pathspec 'lib/Algebra/Field.agda' did not match any file(s) known to git