diff --git a/lib/Haskell/Law/Applicative/List.agda b/lib/Haskell/Law/Applicative/List.agda index 37b2ea3d..c7caf4cf 100644 --- a/lib/Haskell/Law/Applicative/List.agda +++ b/lib/Haskell/Law/Applicative/List.agda @@ -22,7 +22,11 @@ private compositionList : {a b c : Set} → (u : List (b → c)) (v : List (a → b)) (w : List a) → ((((pure _∘_) <*> u) <*> v) <*> w) ≡ (u <*> (v <*> w)) compositionList [] _ _ = refl - compositionList us vs ws = trustMe -- TODO + compositionList (u ∷ us) v w + rewrite sym $ concatMap-++-distr (map (u ∘_) v) (((pure _∘_) <*> us) <*> v) (λ f → map f w) + | sym $ map-<*>-recomp v w u + | compositionList us v w + = refl interchangeList : {a b : Set} → (u : List (a → b)) → (y : a) → (u <*> (pure y)) ≡ (pure (_$ y) <*> u) diff --git a/lib/Haskell/Law/List.agda b/lib/Haskell/Law/List.agda index a01e6eca..4bf7efd5 100644 --- a/lib/Haskell/Law/List.agda +++ b/lib/Haskell/Law/List.agda @@ -4,6 +4,7 @@ open import Haskell.Law.Equality open import Haskell.Prim renaming (addNat to _+ₙ_) open import Haskell.Prim.Foldable open import Haskell.Prim.List +open import Haskell.Prim.Applicative []≠∷ : ∀ x (xs : List a) → [] ≠ x ∷ xs []≠∷ x xs () @@ -37,6 +38,21 @@ map-∘ : ∀ (g : b → c) (f : a → b) xs → map (g ∘ f) xs ≡ (map g ∘ map-∘ g f [] = refl map-∘ g f (x ∷ xs) = cong (_ ∷_) (map-∘ g f xs) +map-concatMap : ∀ (f : a → b) (xs : List a) → (map f xs) ≡ concatMap (λ g → f g ∷ []) xs +map-concatMap f [] = refl +map-concatMap f (x ∷ xs) + rewrite map-concatMap f xs + = refl + +map-<*>-recomp : {a b c : Set} → (xs : List (a → b)) → (ys : List a) → (u : (b → c)) + → ((map (u ∘_) xs) <*> ys) ≡ map u (xs <*> ys) +map-<*>-recomp [] _ _ = refl +map-<*>-recomp (x ∷ xs) ys u + rewrite map-∘ u x ys + | map-++ u (map x ys) (xs <*> ys) + | map-<*>-recomp xs ys u + = refl + -------------------------------------------------- -- _++_ @@ -98,6 +114,14 @@ lengthNat-++ (x ∷ xs) = cong suc (lengthNat-++ xs) ∷-not-identity : ∀ x (xs ys : List a) → (x ∷ xs) ++ ys ≡ ys → ⊥ ∷-not-identity x xs ys eq = []≠∷ x xs (sym $ ++-identity-left-unique (x ∷ xs) (sym eq)) +concatMap-++-distr : ∀ (xs ys : List a) (f : a → List b) → + ((concatMap f xs) ++ (concatMap f ys)) ≡ (concatMap f (xs ++ ys)) +concatMap-++-distr [] ys f = refl +concatMap-++-distr (x ∷ xs) ys f + rewrite ++-assoc (f x) (concatMap f xs) (concatMap f ys) + | concatMap-++-distr xs ys f + = refl + -------------------------------------------------- -- foldr @@ -118,4 +142,4 @@ foldr-fusion : (h : b → c) {f : a → b → b} {g : a → c → c} (e : b) → ∀ (xs : List a) → h (foldr f e xs) ≡ foldr g (h e) xs foldr-fusion h {f} {g} e fuse = foldr-universal (h ∘ foldr f e) g (h e) refl - (λ x xs → fuse x (foldr f e xs)) \ No newline at end of file + (λ x xs → fuse x (foldr f e xs)) diff --git a/lib/Haskell/Law/Monad/List.agda b/lib/Haskell/Law/Monad/List.agda index 3ef94949..9d293751 100644 --- a/lib/Haskell/Law/Monad/List.agda +++ b/lib/Haskell/Law/Monad/List.agda @@ -6,13 +6,15 @@ open import Haskell.Prim.List open import Haskell.Prim.Monad open import Haskell.Law.Monad.Def +open import Haskell.Law.List open import Haskell.Law.Applicative.List -open import Haskell.Law.Equality instance - iLawfulMonadList : IsLawfulMonad List - iLawfulMonadList .leftIdentity a k = trustMe + iLawfulMonadList : IsLawfulMonad List + iLawfulMonadList .leftIdentity a k + rewrite ++-[] (k a) + = refl iLawfulMonadList .rightIdentity [] = refl iLawfulMonadList .rightIdentity (_ ∷ xs) @@ -20,19 +22,18 @@ instance = refl iLawfulMonadList .associativity [] f g = refl - iLawfulMonadList .associativity (_ ∷ xs) f g + iLawfulMonadList .associativity (x ∷ xs) f g rewrite associativity xs f g - = trustMe - - -- foldMapList g (f x) ++ foldMapList g (foldMapList f xs) - -- ≡ - -- foldMapList g (f x ++ foldMapList f xs) + | concatMap-++-distr (f x) (xs >>= f) g + = refl iLawfulMonadList .pureIsReturn _ = refl iLawfulMonadList .sequence2bind [] _ = refl - iLawfulMonadList .sequence2bind (_ ∷ _) [] = refl - iLawfulMonadList .sequence2bind (f ∷ fs) (x ∷ xs) = trustMe + iLawfulMonadList .sequence2bind (f ∷ fs) xs + rewrite sequence2bind fs xs + | map-concatMap f xs + = refl iLawfulMonadList .fmap2bind f [] = refl iLawfulMonadList .fmap2bind f (_ ∷ xs) @@ -40,4 +41,8 @@ instance = refl iLawfulMonadList .rSequence2rBind [] mb = refl - iLawfulMonadList .rSequence2rBind (x ∷ ma) mb = trustMe + iLawfulMonadList .rSequence2rBind (x ∷ ma) mb + rewrite rSequence2rBind ma mb + | map-id mb + = refl + diff --git a/lib/Haskell/Law/Monoid/List.agda b/lib/Haskell/Law/Monoid/List.agda index 28a91357..c6f81d13 100644 --- a/lib/Haskell/Law/Monoid/List.agda +++ b/lib/Haskell/Law/Monoid/List.agda @@ -1,12 +1,10 @@ module Haskell.Law.Monoid.List where open import Haskell.Prim -open import Haskell.Prim.Foldable open import Haskell.Prim.List open import Haskell.Prim.Monoid -open import Haskell.Law.Equality open import Haskell.Law.List open import Haskell.Law.Monoid.Def open import Haskell.Law.Semigroup.Def @@ -25,6 +23,7 @@ instance = refl iLawfulMonoidList .concatenation [] = refl - iLawfulMonoidList .concatenation (x ∷ xs) - rewrite ++-[] x - = trustMe -- TODO + iLawfulMonoidList .concatenation (x ∷ xs) + rewrite ++-[] (x ∷ xs) + | concatenation xs + = refl diff --git a/lib/Haskell/Law/Monoid/Maybe.agda b/lib/Haskell/Law/Monoid/Maybe.agda index 6ac804e4..71ce1f2c 100644 --- a/lib/Haskell/Law/Monoid/Maybe.agda +++ b/lib/Haskell/Law/Monoid/Maybe.agda @@ -5,7 +5,6 @@ open import Haskell.Prim.Maybe open import Haskell.Prim.Monoid -open import Haskell.Law.Equality open import Haskell.Law.Monoid.Def open import Haskell.Law.Semigroup.Def open import Haskell.Law.Semigroup.Maybe @@ -17,5 +16,6 @@ instance iLawfulMonoidMaybe .leftIdentity = λ { Nothing → refl; (Just _) → refl } iLawfulMonoidMaybe .concatenation [] = refl - iLawfulMonoidMaybe .concatenation (x ∷ xs) = trustMe -- TODO - + iLawfulMonoidMaybe .concatenation (x ∷ xs) + rewrite (concatenation xs) + = refl diff --git a/lib/Haskell/Law/Ord/Def.agda b/lib/Haskell/Law/Ord/Def.agda index 4da9149a..4acb6fe4 100644 --- a/lib/Haskell/Law/Ord/Def.agda +++ b/lib/Haskell/Law/Ord/Def.agda @@ -80,9 +80,33 @@ eq2ngt x y h | equality (compare x y) EQ h = refl +lte2LtEq : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ + → ∀ (x y : a) → (x <= y) ≡ (x < y || x == y) +lte2LtEq x y + rewrite lt2LteNeq x y + | compareEq x y + with (x <= y) in h₁ | (compare x y) in h₂ +... | False | LT = refl +... | False | EQ = magic $ exFalso (reflexivity x) $ begin + (x <= x) ≡⟨ (cong (x <=_) (equality x y (begin + (x == y) ≡⟨ compareEq x y ⟩ + (compare x y == EQ) ≡⟨ equality' (compare x y) EQ h₂ ⟩ + True ∎ ) ) ) ⟩ + (x <= y) ≡⟨ h₁ ⟩ + False ∎ +... | False | GT = refl +... | True | LT = refl +... | True | EQ = refl +... | True | GT = refl + gte2GtEq : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ → ∀ (x y : a) → (x >= y) ≡ (x > y || x == y) -gte2GtEq x y = trustMe -- TODO +gte2GtEq x y + rewrite sym $ lte2gte y x + | lte2LtEq y x + | eqSymmetry y x + | lt2gt y x + = refl gte2nlt : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ → ∀ (x y : a) → (x >= y) ≡ not (x < y) @@ -90,8 +114,11 @@ gte2nlt x y rewrite gte2GtEq x y | compareGt x y | compareEq x y - | sym (compareLt x y) - = trustMe -- TODO + | compareLt x y + with compare x y +... | GT = refl +... | EQ = refl +... | LT = refl gte2nLT : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ → ∀ (x y : a) → (x >= y) ≡ (compare x y /= LT) @@ -100,18 +127,17 @@ gte2nLT x y | compareLt x y = refl -lte2LtEq : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ - → ∀ (x y : a) → (x <= y) ≡ (x < y || x == y) -lte2LtEq x y = trustMe -- TODO - lte2ngt : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ → ∀ (x y : a) → (x <= y) ≡ not (x > y) lte2ngt x y rewrite lte2LtEq x y | compareLt x y | compareEq x y - | sym (compareGt x y) - = trustMe -- TODO + | compareGt x y + with compare x y +... | GT = refl +... | EQ = refl +... | LT = refl lte2nGT : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ → ∀ (x y : a) → (x <= y) ≡ (compare x y /= GT) diff --git a/lib/Haskell/Prim.agda b/lib/Haskell/Prim.agda index 60d464b6..abc39993 100644 --- a/lib/Haskell/Prim.agda +++ b/lib/Haskell/Prim.agda @@ -99,6 +99,11 @@ data ⊥ : Set where magic : {A : Set} → ⊥ → A magic () +--principle of explosion +exFalso : {x : Bool} → (x ≡ True) → (x ≡ False) → ⊥ +exFalso {False} () b +exFalso {True} a () + -- Use to bundle up constraints data All {a b} {A : Set a} (B : A → Set b) : List A → Set (a ⊔ b) where instance