-- Generic programming / type families example, based on Generalized Tries -- Adapted from Hinze, Loeh "Type-indexed Datatypes" module FMap where open import Data.Unit open import Data.Maybe open import Data.List hiding (fromMaybe) open import Data.Product open import Data.Char renaming (_==_ to eqChar) open import Data.String open import Data.Nat open import Data.Bool hiding (_≟_) open import Relation.Nullary.Core using (Dec; yes; no) open import Data.Sum open import Relation.Binary.Core -- PART 1: Standard Tries, an optimized dictionary from strings to values. -- helper functions, part of Haskell's library but not Agda's -- update an association list with a new mapping, removing -- the old one. insertAL : ∀ {a v} -> (a -> a -> Bool) -> a -> v -> List (a × v) -> List (a × v) insertAL eq c v [] = [(c , v)] insertAL eq c v ((c' , v') ∷ m) with eq c c' ... | true = (c , v) ∷ m ... | false = (c' , v') ∷ insertAL eq c v m -- reverse bind merge : ∀ { a b c : Set} -> (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c merge f g a with f a ... | nothing = nothing ... | just b = g b -- lookup from an association list. Could use type classes. lookup : ∀ { a v } -> (a -> a -> Bool) -> a -> List (a × v) -> Maybe v lookup eq a [] = nothing lookup eq a ((a' , v) ∷ as) with eq a a' ... | true = just v ... | false = lookup eq a as -- project from a maybe, given a default value fromMaybe : ∀ {a} -> a -> Maybe a -> a fromMaybe x (just y) = y fromMaybe x nothing = x ------------------------------------------------------------------------ -- A tree is a tree structure, where each node contains a character and -- perhaps a value (if the string from the root to this node is mapped). data Trie (v : Set) : Set where mkT : Maybe v × List (Char × Trie v) -> Trie v -- basic operations emptyTrie : ∀ {v} -> Trie v emptyTrie = mkT (nothing , []) insertTrie : ∀ {v} -> List Char -> v -> Trie v -> Trie v insertTrie [] v (mkT ( _ , t)) = mkT (just v , t) insertTrie (a ∷ as) v (mkT (m , ls)) = let inner : _ inner = fromMaybe emptyTrie (lookup eqChar a ls) in mkT (m , insertAL eqChar a (insertTrie as v inner) ls) lookupTrie : ∀ {v} -> List Char -> Trie v -> Maybe v lookupTrie [] (mkT (m , _)) = m lookupTrie (a ∷ as) (mkT (_ , t)) with lookup eqChar a t ... | just u = lookupTrie as u ... | nothing = nothing -- Example trie alist1 : List (String × Bool) alist1 = ( ("c" , true) ∷ ("ca" , false) ∷ ("cab" , true) ∷ ("car" , true) ∷ ("care" , true) ∷ ("cax" , false) ∷ ("carrot" , true) ∷ ("cd" , false) ∷ ("cdr" , true) ∷ [] ) alist : List (List Char × Bool) alist = Data.List.map (Data.Product.map toList (λ x -> x)) alist1 trie : Trie Bool trie = foldr (uncurry insertTrie) emptyTrie alist ------------------------------------------------------------- -- Part 2: How do we know that a trie is more efficient? -- Lets compare the sizes, using generic programming -- -- This is a simple example of generic programming to -- get us warmed up. It also demonstrates (one way) to -- extend generic programs to arbitrary datatypes. ------------------------------------------------------ -- Datatype of type represntations data R : Set -> Set1 where RChar : R Char RUnit : R ⊤ RBool : R Bool RSum : ∀ {a b} -> R a -> R b -> R (a ⊎ b) RProd : ∀ {a b} -> R a -> R b -> R (a × b) RList : ∀ {a} -> R a -> R (List a) RTrie : ∀ {a} -> R a -> R (Trie a) -- We'll define the cases for List and Trie in terms of the -- other cases (Unit, Either, Prod, etc.) So we need some -- helper functions that let us convert between Lists/Tries -- and their structures. --- isomorphisms for lists listRep : ∀ {a} -> R a -> R ( ⊤ ⊎ (a × List a) ) listRep ra = RSum RUnit (RProd ra (RList ra)) toListR : ∀ {a} -> ⊤ ⊎ (a × List a) -> List a toListR (inj₁ _) = [] toListR (inj₂ ( a , as )) = ( a ∷ as ) fromListR : ∀ {a} -> List a -> ⊤ ⊎ (a × List a) fromListR [] = inj₁ tt fromListR (a ∷ as) = inj₂ (a , as) -- Adga can prove that it is an isomorphism listiso1 : ∀ {a : Set} -> (l : List a) -> toListR (fromListR l) ≡ l listiso1 [] = refl listiso1 (a ∷ as) = refl listiso2 : forall {a : Set} -> (l : ⊤ ⊎ (a × List a)) -> fromListR (toListR l) ≡ l listiso2 (inj₁ _) = refl listiso2 (inj₂ ( _ , _ )) = refl --- isomorphism for tries trieRep : ∀ {v} -> R v -> R ( (⊤ ⊎ v) × List (Char × Trie v) ) trieRep ra = RProd (RSum RUnit ra) (RList (RProd RChar (RTrie ra))) toTrie : ∀ {v} -> ((⊤ ⊎ v) × List (Char × Trie v)) -> Trie v toTrie (inj₁ tt , alist) = mkT (nothing , alist) toTrie (inj₂ v , alist) = mkT (just v , alist) fromTrie : ∀ {v} -> Trie v -> ((⊤ ⊎ v) × List (Char × Trie v)) fromTrie (mkT (nothing , alist)) = (inj₁ tt , alist) fromTrie (mkT (just v , alist)) = (inj₂ v , alist) -- Generic function for calculating the size of a data-structure rsize : forall { a : Set } -> (ra : R a) -> a -> ℕ rsize RChar _ = 1 rsize RUnit _ = 0 -- takes no space to store rsize RBool _ = 1 rsize (RSum ra rb) (inj₁ x) = 1 + rsize ra x rsize (RSum a b) (inj₂ x) = 1 + rsize b x rsize (RProd a b) (x , y) = rsize a x + rsize b y -- don't need to store tag rsize (RList a) l = rsize (listRep a) (fromListR l) rsize (RTrie a) t = rsize (trieRep a) (fromTrie t) rsize' : forall {a : Set}{ra : R a} -> a -> ℕ rsize' {_}{ra} = rsize ra -- Unfortunately, AGDA cannot figure out this implicit parameter s3 = rsize' alist s4 = rsize' trie ---------------------------------------------------------------- -- Alternate way of GP in Agda using "universes" -- A DT of type representations data Type : Set where TChar : Type TUnit : Type TBool : Type TSum : Type -> Type -> Type TProd : Type -> Type -> Type TList : Type -> Type TTrie : Type -> Type i : Type -> Set i (TChar) = Char i (TUnit) = ⊤ i (TBool) = Bool i (TSum t1 t2) = i t1 ⊎ i t2 i (TProd t1 t2) = i t1 × i t2 i (TList t1) = List (i t1) i (TTrie t1) = Trie (i t1) -- create list representation listDef : Type -> Type listDef ra = TSum TUnit (TProd ra (TList ra)) --- create trie representation trieDef : Type -> Type trieDef a = TProd (TSum TUnit a) (TList (TProd TChar (TTrie a))) --- isomorphism for bools boolDef : Type boolDef = TSum TUnit TUnit toBool : ⊤ ⊎ ⊤ -> Bool toBool (inj₁ tt) = false toBool (inj₂ tt) = true fromBool : Bool -> ⊤ ⊎ ⊤ fromBool false = inj₁ tt fromBool true = inj₂ tt ------------------------------------------------ -- Generic function for calculating the size of a data-structure -- Agda cannot prove this function total b/c of defs size : (a : Type) -> i a -> ℕ size TChar _ = 1 size TUnit _ = 0 -- takes no space to store size (TSum a b) (inj₁ x) = 1 + size a x size (TSum a b) (inj₂ x) = 1 + size b x size (TProd a b) (x , y) = size a x + size b y -- don't need to store tag size (TList a) l = size (listDef a) (fromListR l) size (TTrie a) t = size (trieDef a) (fromTrie t) size TBool b = size boolDef (fromBool b) s1 = size (TList (TProd (TList TChar) TBool)) alist s2 = size (TTrie TBool) trie ------------------------------------------------------------- -- Part 3: Generalized tries -- How to use generic programming to derive the definitions of -- tries above? -- A generic trie, indexed by types {- Haskell definitions: type family FMap t v type instance FMap () v = Maybe v type instance FMap Char v = [(Char,v)] type instance FMap (Either t1 t2) v = (FMap t1 v, FMap t2 v) type instance FMap (t1, t2) v = FMap t1 (FMap t2 v) type instance FMap [t1] v = FMapList t1 v data FMapList t1 v = FMapList (FMap (Either () (t1, [t1])) v) -} mutual FMap : Type -> Set -> Set FMap TUnit v = Maybe v FMap TChar v = List (Char × v) FMap (TSum t1 t2) v = FMap t1 v × FMap t2 v FMap (TProd t1 t2) v = FMap t1 (FMap t2 v) FMap TBool v = (Maybe v × Maybe v) FMap (TList t1) v = Rec (listDef t1) v FMap (TTrie t1) v = Rec (trieDef t1) v data Rec ( t1 : Type) (v : Set) : Set where roll : FMap t1 v -> Rec t1 v fmlookup : ∀ {v} -> (t : Type) -> i t -> FMap t v -> Maybe v fmlookup TUnit tt m = m fmlookup TChar c m = lookup eqChar c m fmlookup (TSum t1 t2) (inj₁ k1) (m1 , m2) = fmlookup t1 k1 m1 fmlookup (TSum t1 t2) (inj₂ k2) (m1 , m2) = fmlookup t2 k2 m2 fmlookup (TProd t1 t2) (k1 , k2) m = merge (fmlookup t1 k1) (fmlookup t2 k2) m fmlookup TBool true (m1 , m2) = m1 fmlookup TBool false (m1 , m2) = m2 fmlookup (TList t1) k (roll m) = fmlookup (listDef t1) (fromListR k) m fmlookup (TTrie t1) k (roll m) = fmlookup (trieDef t1) (fromTrie k) m fmempty : ∀ {v} -> (t : Type) -> FMap t v fmempty TUnit = nothing fmempty TChar = [] fmempty (TSum t1 t2) = (fmempty t1 , fmempty t2) fmempty (TProd t1 t2) = fmempty t1 fmempty TBool = (fmempty boolDef) fmempty (TList t1) = roll (fmempty (listDef t1)) fmempty (TTrie t1) = roll (fmempty (trieDef t1)) fminsert : ∀ {v} -> (t : Type) -> i t -> v -> FMap t v -> FMap t v fminsert TUnit tt v m = just v fminsert TChar c v m = insertAL eqChar c v m fminsert (TSum t1 t2) (inj₁ k1) v (m1 , m2) = (fminsert t1 k1 v m1 , m2) fminsert (TSum t1 t2) (inj₂ k2) v (m1 , m2) = (m1 , fminsert t2 k2 v m2) fminsert (TProd t1 t2) (k1 , k2) v m = let m2 : _ m2 = fromMaybe (fmempty t2) (fmlookup t1 k1 m) in fminsert t1 k1 (fminsert t2 k2 v m2) m fminsert (TList t1) k v (roll m) = roll (fminsert (listDef t1) (fromListR k) v m) fminsert (TTrie t1) k v (roll m) = roll (fminsert (trieDef t1) (fromTrie k) v m) fminsert TBool true v (m1 , m2) = (just v , m2) fminsert TBool false v (m1 , m2) = (m1 , just v) ----------------------------------------------------------------------- -- Examples fmap1 : FMap (TList TChar) Bool fmap1 = foldr (uncurry (fminsert (TList TChar))) (fmempty {Bool} (TList TChar)) alist ---------------------------------------------------------------