Resolving a "diamond inheritance" class in lean - diamond-problem

I have a pretty basic construction of loops in mind for lean. I construct a class for magmata, a class for quasigroups (cancellative magmata), and a class for unital magmata. From there a loop is just something that is both a quasigroup and a unital magma.
In Haskell this would look like
class Magma a where
add :: a -> a -> a
class Magma a => Unital a where
unit :: a
class Magma a => Quasigroup a where
left_div :: a -> a -> a
right_div :: a -> a -> a
class (Quasigroup a, Unital a) => Loop a
So I try to translate that to lean:
universe u
class magma (α : Type u) :=
( add : α → α → α )
class unital (α : Type u) extends magma α :=
( unit : α )
( left_id : ∀ a : α, add unit a = a )
( right_id : ∀ a : α, add a unit = a )
class quasigroup (α : Type u) extends magma α :=
( left_div : α → α → α )
( right_div : α → α → α )
( left_cancel : ∀ a b : α, add a (left_div a b) = b )
( right_cancel : ∀ a b : α, add (right_div b a) a = b )
class loop (α : Type u) extends quasigroup α, unital α
But lean complains that:
invalid 'structure' header, field 'to_magma' from 'unital' has already been declared
Which is pretty cryptic, but if we play around with things, it becomes apparent that this is some sort of problem resembling diamond inheritance. It doesn't like that we have made two paths from loop to magma.
How can I tell lean that these are the same magmata and resolve this issue?

On Lean 3.35.1, you have several possible solutions. For Haskell-like record merging, there is old_structure_cmd:
universe u
class magma (α : Type u) :=
(add : α → α → α)
class unital (α : Type u) extends magma α :=
(unit : α)
(left_id : ∀ a : α, add unit a = a)
(right_id : ∀ a : α, add a unit = a)
class quasigroup (α : Type u) extends magma α :=
(left_div : α → α → α)
(right_div : α → α → α)
(left_cancel : ∀ a b : α, add a (left_div a b) = b)
(right_cancel : ∀ a b : α, add (right_div b a) a = b)
set_option old_structure_cmd true
class loop (α : Type u) extends quasigroup α, unital α.
That will work as you expect. However, the downside of old_structure_cmd is that the structures are all "flattened" and grow in size. The "new" way is to have a main "trunk" of structure, and create offshoot inheritance:
universe u
class magma (α : Type u) :=
(add : α → α → α)
class unital (α : Type u) extends magma α :=
(unit : α)
(left_id : ∀ a : α, add unit a = a)
(right_id : ∀ a : α, add a unit = a)
class quasigroup (α : Type u) extends magma α :=
(left_div : α → α → α)
(right_div : α → α → α)
(left_cancel : ∀ a b : α, add a (left_div a b) = b)
(right_cancel : ∀ a b : α, add (right_div b a) a = b)
class loop (α : Type u) extends quasigroup α :=
(unit : α)
(left_id : ∀ a : α, add unit a = a)
(right_id : ∀ a : α, add a unit = a)
instance loop.to_unital {α : Type u} [h : loop α] : unital α :=
{ ..h }

Related

Computing the subsets of natural numbers in AGDA

I'm using AGDA to do some classical mathematical proofs. I'd like to prove that the number of subsets of a set of cardinality n is equal to 2^n (i.e pow (2, n)). To do so, my strategy would be the following :
1) Write a function sub n, that, given each natural, it returns a list of all the possible subsets of naturals less or equal to n.
2) Write two functions "length " and "pow ", that separately compute the length of the list and 2^n
3) Put the 3 functions together to prove the statement.
However, I'm having troubles to solve point 1 ). My idea is to make the function return a list of type "list Nat", but I am having some problem to implement the recursion. Basically my idea for the inductive step is to associate to each subset of "n" two new subsets : itself and the subset obtained adding "n+1".
Do you think it is an effective strategy? And moreover, how can I solve my troubles with point 1?
Thanks
By the way, I have solved my problem using the strategy I proposed. To define the function that compute the number of subsets I use the standard map function and an additional auxiliary function add-to-list:
add-to-list : ℕ → List ℕ → List ℕ
add-to-list n x = n ∷ x
subℕ : ℕ → List ( List ℕ )
subℕ zero = [ 0 ] ∷ []
subℕ (suc x) = subℕ x ++ ( map ( add-to-list x ) ( subℕ x ) )
Then, I prove the two following elementary lemmas:
l-aux : ∀ {A : Set } { x y : List A } → ( length ( x ++ y ) )≡( ( length x ) + ( length y ))
l-aux {A} {[]} {y} = refl
l-aux {A} {x ∷ x₁} {y} rewrite l-aux {A} { x₁} {y} = refl
l-aux-1 : ∀ {A : Set } { x : List A } { f : A → A } → ( length ( map f x ) ) ≡ ( length x )
l-aux-1 {A} {[]} {f} = refl
l-aux-1 {A} {x ∷ x₁} {f} rewrite l-aux-1 {A} { x₁} {f} = refl
And the proof is reduced to elementary recursion :
number-of-subsets : ∀ ( n : ℕ ) → ( length ( subℕ n ) ) ≡ ( pow 2 n )
number-of-subsets zero = refl
number-of-subsets (suc n ) rewrite l-aux {List ℕ} {subℕ n} { map ( add-to-list n ) (subℕ n)} | l-aux-1 {List ℕ} {subℕ n} {add-to-list n } | number-of-subsets n | +0 (pow 2 n ) = refl

Guidance on very shallow embedding VHDL in AGDA

for my project in Programming Languages I am doing a very shallow and simple embedding VHDL digital circuits in agda. The aim is to write the syntax, static semantics, dynamic semantics and then write some proofs to show our understanding of the material. Up till now I have written the following code:
data Ckt : Set where
var : String → Ckt
bool : Bool → Ckt
empty : Ckt
gate : String → ℕ → ℕ → Ckt -- name in out
series : String → Ckt → Ckt → Ckt -- name ckt1 ckt2
parallel : String → Ckt → Ckt → Ckt --name ckt1 ckt2
And : Ckt
And = gate "And" 2 1
data Ctxt : Set where
□ : Ctxt
_,_ : (String × ℕ × ℕ) → Ctxt → Ctxt
_≈_ : Ctxt → Ctxt → Set
□ ≈ □ = ⊤
□ ≈ (_ , _) = ⊥
(_ , _) ≈ □ = ⊥
((s₁ , (in₁ , out₂)) , Γ₁) ≈ ((s₂ , (in₃ , out₄)) , Γ₂) = True (s₁ ≟ s₂) × in₁ ≡ in₃ × out₂ ≡ out₄ × Γ₁ ≈ Γ₂
--static Semantics
data _⊢_ : (Γ : Ctxt) → (e : Ckt) → Set where
VarT : ∀ {Γ s τ} → ((s , τ) ∈ Γ) → Γ ⊢ var s
BoolT : ∀ {Γ b} → Γ ⊢ bool b
EmptyT : ∀ {Γ} → Γ ⊢ empty
GateT : ∀ {Γ s i o} → (s , (i , o)) ∈ Γ → Γ ⊢ gate s i o
SeriesT : ∀ {Γ s c₁ c₂} → Γ ⊢ c₁ → Γ ⊢ c₂ → Γ ⊢ series s c₁ c₂
ParallelT : ∀ {Γ s c₁ c₂} → Γ ⊢ c₁ → Γ ⊢ c₂ → Γ ⊢ parallel s c₁ c₂
What I am stuck at is how can I convert this program so as to carry out the program execution i-e I don't know how to start writing the dynamic semantics. Also, if there is any way to improve the syntax or statics of my current program then please let me know.

Understanding Assignment Solution in Agda

Consider the following extracted piece of code for proving the "Unicity of Typing" for variable in Agda:
unicity : ∀ {Γ₁ Γ₂ e τ₁ τ₂} → (Γ₁ ⊢ e ∷ τ₁) → (Γ₂ ⊢ e ∷ τ₂) → (Γ₁ ≈ Γ₂) → (τ₁ ∼ τ₂)
unicity (VarT here) (VarT here) (_ , ( τ∼ , _ )) = τ∼
unicity (VarT here) (VarT (ski`p {α = α} lk2)) (s≡s' , ( _ , _ )) = ⊥-elim (toWitnessFalse α (toWitness` s≡s'))
unicity (VarT (skip {α = α} lk1)) (VarT here) (s'≡s , ( _ , _ )) = ⊥-elim (toWitnessFalse α (toWitness s'≡s))
unicity (VarT (skip lk1)) (VarT (skip lk2)) (_ ,( _ , Γ≈ )) = unicity (VarT lk1) (VarT lk2) Γ≈
I need an explanation on the working of ⊥-elim , toWitnessFalse and toWitness. Also, what do the expressions ⊤ and ⊥ mean/stand for?
⊥ is the empty type, so (in a total, consistent language) you can never construct a value of type ⊥. But this also means that any proposition you can think of, follows from ⊥. This is what ⊥-elim witnesses:
⊥-elim : ∀ {w} {Whatever : Set w} → ⊥ → Whatever
This is very useful in practice because you might be writing proofs under some assumption, and some of those assumptions might be ⊥, or they might be negative statements (A → ⊥ for some A) and you can prove the A as well, etc. Then, what you find out is effectively that you don't have to care about that particular branch anymore, since it is impossible; but then, just because you don't care, you still have to formally satisfy the result type somehow. This is what ⊥-elim gives you.
toWitness's type and related definitions are as follows:
T : Bool → Set
T true = ⊤
T false = ⊥
⌊_⌋ : ∀ {p} {P : Set p} → Dec P → Bool
⌊ yes _ ⌋ = true
⌊ no _ ⌋ = false
True : ∀ {p} {P : Set p} → Dec P → Set
True Q = T ⌊ Q ⌋
toWitness : ∀ {p} {P : Set p} {Q : Dec P} → True Q → P
Given a Q : Dec P, True Q is either ⊤ (if Q = yes _) or ⊥ (if Q = no _). The only way to call toWitness, then, is to have Q say that P is true and pass the trivial unit constructor tt : ⊤; the only other possibility would be to have Q say that P is false, and pass as an argument a ⊥ but as we've seen, that's not possible. In summary, toWitness says that if Q tells us the decision that P holds, then we can get a proof of P from Q.
toWitnessFalse is exactly the same with the roles reversed: if Q tells us the decision that P doesn't hold, then we can get a proof of ¬ P from Q.

How to define abstract types in agda

How is it possible to define abstract types in Agda. We use typedecl in Isabelle to do so.
More precisely, I would like the agda counterpart of the below code in Isabelle:
typedecl A
Thanks
You could use parametrized modules. Let's have a look at an example: we start by introducing a record Nats packing a Set together with operations on it.
record Nats : Set₁ where
field
Nat : Set
zero : Nat
succ : Nat → Nat
primrec : {B : Set} (z : B) (s : Nat → B → B) → Nat → B
We can then define a module parametrized by such a structure. Addition and multiplication can be defined in terms of primitive recursion, zero and successor.
open import Function
module AbstractType (nats : Nats) where
open Nats nats
add : Nat → Nat → Nat
add m n = primrec n (const succ) m
mult : Nat → Nat → Nat
mult m n = primrec zero (const (add n)) m
Finally we can provide instances of Nats. Here I reuse the natural numbers as defined in the standard library but one could use binary numbers for instance.
open Nats
Natsℕ : Nats
Natsℕ = record { Nat = ℕ
; zero = 0
; succ = suc
; primrec = primrecℕ }
where
open import Data.Nat
primrecℕ : {B : Set} (z : B) (s : ℕ → B → B) → ℕ → B
primrecℕ z s zero = z
primrecℕ z s (suc n) = s n $ primrecℕ z s n
Passing this instance to the module, gives us the corresponding add / mult operations:
open import Relation.Binary.PropositionalEquality
example :
let open AbstractType Natsℕ
in mult (add 0 3) 3 ≡ 9
example = refl

Termination-checking of function over a trie

I'm having difficulty convincing Agda to termination-check the function fmap below and similar functions defined recursively over the structure of a Trie. A Trie is a trie whose domain is a Type, an object-level type formed from unit, products and fixed points (I've omitted coproducts to keep the code minimal). The problem seems to relate to a type-level substitution I use in the definition of Trie. (The expression const (μₜ τ) * τ means apply the substitution const (μₜ τ) to the type τ.)
module Temp where
open import Data.Unit
open import Category.Functor
open import Function
open import Level
open import Relation.Binary
-- A context is just a snoc-list.
data Cxt {𝒂} (A : Set 𝒂) : Set 𝒂 where
ε : Cxt A
_∷ᵣ_ : Cxt A → A → Cxt A
-- Context membership.
data _∈_ {𝒂} {A : Set 𝒂} (a : A) : Cxt A → Set 𝒂 where
here : ∀ {Δ} → a ∈ Δ ∷ᵣ a
there : ∀ {Δ a′} → a ∈ Δ → a ∈ Δ ∷ᵣ a′
infix 3 _∈_
-- Well-formed types, using de Bruijn indices.
data _⊦ (Δ : Cxt ⊤) : Set where
nat : Δ ⊦
𝟏 : Δ ⊦
var : _ ∈ Δ → Δ ⊦
_+_ _⨰_ : Δ ⊦ → Δ ⊦ → Δ ⊦
μ : Δ ∷ᵣ _ ⊦ → Δ ⊦
infix 3 _⊦
-- A closed type.
Type : Set
Type = ε ⊦
-- Type-level substitutions and renamings.
Sub Ren : Rel (Cxt ⊤) zero
Sub Δ Δ′ = _ ∈ Δ → Δ′ ⊦
Ren Δ Δ′ = ∀ {x} → x ∈ Δ → x ∈ Δ′
-- Renaming extension.
extendᵣ : ∀ {Δ Δ′} → Ren Δ Δ′ → Ren (Δ ∷ᵣ _) (Δ′ ∷ᵣ _)
extendᵣ ρ here = here
extendᵣ ρ (there x) = there (ρ x)
-- Lift a type renaming to a type.
_*ᵣ_ : ∀ {Δ Δ′} → Ren Δ Δ′ → Δ ⊦ → Δ′ ⊦
_ *ᵣ nat = nat
_ *ᵣ 𝟏 = 𝟏
ρ *ᵣ (var x) = var (ρ x)
ρ *ᵣ (τ₁ + τ₂) = (ρ *ᵣ τ₁) + (ρ *ᵣ τ₂)
ρ *ᵣ (τ₁ ⨰ τ₂) = (ρ *ᵣ τ₁) ⨰ (ρ *ᵣ τ₂)
ρ *ᵣ (μ τ) = μ (extendᵣ ρ *ᵣ τ)
-- Substitution extension.
extend : ∀ {Δ Δ′} → Sub Δ Δ′ → Sub (Δ ∷ᵣ _) (Δ′ ∷ᵣ _)
extend θ here = var here
extend θ (there x) = there *ᵣ (θ x)
-- Lift a type substitution to a type.
_*_ : ∀ {Δ Δ′} → Sub Δ Δ′ → Δ ⊦ → Δ′ ⊦
θ * nat = nat
θ * 𝟏 = 𝟏
θ * var x = θ x
θ * (τ₁ + τ₂) = (θ * τ₁) + (θ * τ₂)
θ * (τ₁ ⨰ τ₂) = (θ * τ₁) ⨰ (θ * τ₂)
θ * μ τ = μ (extend θ * τ)
data Trie {𝒂} (A : Set 𝒂) : Type → Set 𝒂 where
〈〉 : A → 𝟏 ▷ A
〔_,_〕 : ∀ {τ₁ τ₂} → τ₁ ▷ A → τ₂ ▷ A → τ₁ + τ₂ ▷ A
↑_ : ∀ {τ₁ τ₂} → τ₁ ▷ τ₂ ▷ A → τ₁ ⨰ τ₂ ▷ A
roll : ∀ {τ} → (const (μ τ) * τ) ▷ A → μ τ ▷ A
infixr 5 Trie
syntax Trie A τ = τ ▷ A
{-# NO_TERMINATION_CHECK #-}
fmap : ∀ {a} {A B : Set a} {τ} → (A → B) → τ ▷ A → τ ▷ B
fmap f (〈〉 x) = 〈〉 (f x)
fmap f 〔 σ₁ , σ₂ 〕 = 〔 fmap f σ₁ , fmap f σ₂ 〕
fmap f (↑ σ) = ↑ (fmap (fmap f) σ)
fmap f (roll σ) = roll (fmap f σ)
It would seem that fmap recurses into a strictly smaller argument in each case; certainly the product case is fine if I remove recursive types. On the other hand, the definition handles recursive types fine if I remove products.
What's the simplest way to proceed here? The inline/fuse trick does not look particularly applicable, but maybe it is. Or should I be looking for another way to deal with the substitution in the definition of Trie?
The inline/fuse trick can be applied in (perhaps) surprising way. This trick is suited for problems of this sort:
data Trie (A : Set) : Set where
nil : Trie A
node : A → List (Trie A) → Trie A
map-trie : {A B : Set} → (A → B) → Trie A → Trie B
map-trie f nil = nil
map-trie f (node x xs) = node (f x) (map (map-trie f) xs)
This function is structurally recursive, but in a hidden way. map just applies map-trie f to the elements of xs, so map-trie gets applied to smaller (sub-)tries. But Agda doesn't look through the definition of map to see that it doesn't do anything funky. So we must apply the inline/fuse trick to get it past termination checker:
map-trie : {A B : Set} → (A → B) → Trie A → Trie B
map-trie f nil = nil
map-trie {A} {B} f (node x xs) = node (f x) (map′ xs)
where
map′ : List (Trie A) → List (Trie B)
map′ [] = []
map′ (x ∷ xs) = map-trie f x ∷ map′ xs
Your fmap function shares the same structure, you map a lifted function of some sort. But what to inline? If we follow the example above, we should inline fmap itself. This looks and feels a bit strange, but indeed, it works:
fmap fmap′ : ∀ {a} {A B : Set a} {τ} → (A → B) → τ ▷ A → τ ▷ B
fmap f (〈〉 x) = 〈〉 (f x)
fmap f 〔 σ₁ , σ₂ 〕 = 〔 fmap f σ₁ , fmap f σ₂ 〕
fmap f (↑ σ) = ↑ (fmap (fmap′ f) σ)
fmap f (roll σ) = roll (fmap f σ)
fmap′ f (〈〉 x) = 〈〉 (f x)
fmap′ f 〔 σ₁ , σ₂ 〕 = 〔 fmap′ f σ₁ , fmap′ f σ₂ 〕
fmap′ f (↑ σ) = ↑ (fmap′ (fmap f) σ)
fmap′ f (roll σ) = roll (fmap′ f σ)
There's another technique you can apply: it's called sized types. Instead of relying on the compiler to figure out when somethig is or is not structurally recursive, you instead specify it directly. However, you have to index your data types by a Size type, so this approach is fairly intrusive and cannot be applied to already existing types, but I think it is worth mentioning.
In its simplest form, sized type behaves as a type indexed by a natural number. This index specifies the upper bound of structural size. You can think of this as an upper bound for the height of a tree (given that the data type is an F-branching tree for some functor F). Sized version of List looks almost like a Vec, for example:
data SizedList (A : Set) : ℕ → Set where
[] : ∀ {n} → SizedList A n
_∷_ : ∀ {n} → A → SizedList A n → SizedList A (suc n)
But sized types add few features that make them easier to use. You have a constant ∞ for the case when you don't care about the size. suc is called ↑ and Agda implements few rules, such as ↑ ∞ = ∞.
Let's rewrite the Trie example to use sized types. We need a pragma at the top of the file and one import:
{-# OPTIONS --sized-types #-}
open import Size
And here's the modified data type:
data Trie (A : Set) : {i : Size} → Set where
nil : ∀ {i} → Trie A {↑ i}
node : ∀ {i} → A → List (Trie A {i}) → Trie A {↑ i}
If you leave the map-trie function as is, the termination checker is still going to complain. That's because when you don't specify any size, Agda will fill in infinity (i.e. don't-care value) and we are back at the beginning.
However, we can mark map-trie as size-preserving:
map-trie : ∀ {i A B} → (A → B) → Trie A {i} → Trie B {i}
map-trie f nil = nil
map-trie f (node x xs) = node (f x) (map (map-trie f) xs)
So, if you give it a Trie bounded by i, it will give you another Trie bounded by i as well. So map-trie can never make the Trie larger, only equally large or smaller. This is enough for the termination checker to figure out that map (map-trie f) xs is okay.
This technique can also be applied to your Trie:
open import Size
renaming (↑_ to ^_)
data Trie {𝒂} (A : Set 𝒂) : {i : Size} → Type → Set 𝒂 where
〈〉 : ∀ {i} → A →
Trie A {^ i} 𝟏
〔_,_〕 : ∀ {i τ₁ τ₂} → Trie A {i} τ₁ → Trie A {i} τ₂ →
Trie A {^ i} (τ₁ + τ₂)
↑_ : ∀ {i τ₁ τ₂} → Trie (Trie A {i} τ₂) {i} τ₁ →
Trie A {^ i} (τ₁ ⨰ τ₂)
roll : ∀ {i τ} → Trie A {i} (const (μ τ) * τ) →
Trie A {^ i} (μ τ)
infixr 5 Trie
syntax Trie A τ = τ ▷ A
fmap : ∀ {i 𝒂} {A B : Set 𝒂} {τ} → (A → B) → Trie A {i} τ → Trie B {i} τ
fmap f (〈〉 x) = 〈〉 (f x)
fmap f 〔 σ₁ , σ₂ 〕 = 〔 fmap f σ₁ , fmap f σ₂ 〕
fmap f (↑ σ) = ↑ fmap (fmap f) σ
fmap f (roll σ) = roll (fmap f σ)

Resources