I am writing an undergraduate thesis on usefulness of dependent types.
I am trying to construct a container, that can only be constructed into a sorted list, so that it is proven sorted by construction:
import Data.So
mutual
data SortedList : (a : Type) -> {ord : Ord a) -> Type where
SNil : SortedList a
SMore : (ord : Ord a) => (el: a) -> (xs : SortedList a) -> So (canPrepend el xs) -> SortedList a
canPrepend : Ord a => a -> SortedList a -> Bool
canPrepend el SNil = True
canPrepend el (SMore x xs prf) = el <= x
SMore requires a runtime proof that the element being prepended is smaller or equal than the smallest (first) element in the sorted list.
To sort an unsorted list, I have created a function sinsert that takes a sorted list and inserts an element and returns a sorted list:
sinsert : (ord : Ord a) => SortedList a {ord} -> a -> SortedList a {ord}
sinsert SNil el = SMore el SNil Oh
sinsert (SMore x xs prf) el = either
(\p =>
-- if el <= x we can prepend it directly
SMore el (SMore x xs prf) p
)
(\np =>
-- if not (el <= x) then we have to insert it in the tail somewhere
-- does not (el <= x) imply el > x ???
-- we construct a new tail by inserting el into xs
let (SMore nx nxs nprf) = (sinsert xs el) in
-- we get two cases:
-- 1) el was prepended to xs and is now the
-- smalest element in the new tail
-- we know that el == nx
-- therefor we can substitute el with nx
-- and we get nx > x and this also means
-- x < nx and also x <= nx and we can
-- prepend x to the new tail
-- 2) el was inserted somewhere deeper in the
-- tail. The first element of the new tail
-- nx is the same as it was in the original
-- tail, therefor we can prepend x to the
-- new tail based on the old proof `prf`
either
(\pp =>
SMore x (SMore nx nxs nprf) ?iins21
)
(\npp =>
SMore x (SMore nx nxs nprf) ?iins22
) (choose (el == nx))
) (choose (el <= x))
I am having trouble constructing the proofs (?iins21, ?iins22) and I would appreciate some help. I may be relying on an assumption that does not hold, but I do not see it.
I would also like to encourage you to provide a better solution for constructing a sorted list (maybe a normal list with a proof value that it is sorted?)
I think that the main problem with your proofs there is that, as Cactus noted in a comment, is that you don't have properties like transitivity and antisymmetry that are needed for the proof of insertion sort to work. However, you can still make a polymorphic container: the Poset class from Decidable.Order in contrib contains exactly the properties that you want. However, Decidable.Order.Order is better in this case since it encapsulates the totality of the relation, ensuring that for any two elements we can get a proof that one of them is smaller.
I have another insertion sort algorithm that I was working on anyway that uses Order; it also explicitly decomposes the distintion between Empty and NonEmpty lists and keeps the max (the largest element that can now be added to the list) value in the type of NonEmpty lists, which simplifies proofs somewhat.
I am also in the process of learning Idris, so this code may not be the most idiomatic; also, many thanks to Melvar and {AS} on the #idris Freenode IRC channel for helping me figure out why previous versions didn't work.
The weird with (y) | <pattern matches on y> syntax in sinsert is there in order to bind y for assert_smaller, since, for some reason, y#(NonEmpty xs) does not work.
I hope this is helpful!
import Data.So
import Decidable.Order
%default total
data NonEmptySortedList : (a : Type)
-> (po : a -> a -> Type)
-> (max : a)
-> Type where
SOne : (el : a) -> NonEmptySortedList a po el
SMany : (el : a)
-> po el max
-> NonEmptySortedList a po max
-> NonEmptySortedList a po el
data SortedList : (a : Type) -> (po : a -> a -> Type) -> Type where
Empty : SortedList _ _
NonEmpty : NonEmptySortedList a po _ -> SortedList a po
head : NonEmptySortedList a _ _ -> a
head (SOne a) = a
head (SMany a _ _) = a
tail : NonEmptySortedList a po _ -> SortedList a po
tail (SOne _) = Empty
tail (SMany _ _ xs) = NonEmpty xs
max : {m : a} -> NonEmptySortedList a _ m -> a
max {m} _ = m
newMax : (Ordered a po) => SortedList a po -> a -> a
newMax Empty x = x
newMax (NonEmpty xs) x = either (const x)
(const (max xs))
(order {to = po} x (max xs))
either' : {P : Either a b -> Type}
-> (f : (l : a) -> P (Left l))
-> (g : (r : b) -> P (Right r))
-> (e : Either a b) -> P e
either' f g (Left l) = f l
either' f g (Right r) = g r
sinsert : (Ordered a po)
=> (x : a)
-> (xs : SortedList a po)
-> NonEmptySortedList a po (newMax xs x)
sinsert x y with (y)
| Empty = SOne {po = po} x
| (NonEmpty xs) = either' { P = NonEmptySortedList a po
. either (const x) (const (max xs))
}
insHead
insTail
(order {to = po} x (max xs))
where insHead : po x (max xs) -> NonEmptySortedList a po x
insHead p = SMany x p xs
max_lt_newmax : po (max xs) x -> po (max xs) (newMax (tail xs) x)
max_lt_newmax max_xs_lt_x with (xs)
| (SOne _) = max_xs_lt_x
| (SMany _ max_xs_lt_max_xxs xxs)
= either' { P = po (max xs) . either (const x)
(const (max xxs))}
(const {a = po (max xs) x} max_xs_lt_x)
(const {a = po (max xs) (max xxs)} max_xs_lt_max_xxs)
(order {to = po} x (max xxs))
insTail : po (max xs) x -> NonEmptySortedList a po (max xs)
insTail p = SMany (max xs)
(max_lt_newmax p)
(sinsert x (assert_smaller y (tail xs)))
insSort : (Ordered a po) => List a -> SortedList a po
insSort = foldl (\xs, x => NonEmpty (sinsert x xs)) Empty
Related
I implement function which adds an element once to every list of a list.
example:
f :: a -> [[a]] -> [[[a]]]
f 7 [[1],[2],[3]]
[[[7,1],[2],[3]],[[1],[7,2],[3]],[[1],[2],[7,3]]]
I start with this solution:
f :: a -> [[a]] -> [[[a]]]
f e xs = ((\n -> (\(x,l)-> if x==n then e:l else l) <$> zip [1..] xs) <$> [1..length xs])
Can you please provide some more nice implementations of this function?
You can implement this with recursion. As base case we consider an empty list:
f _ [] = []
for non-empty lists (x:xs) we can use the first item, which is the first sublist. We thus can produce a list where we prepend the first sublist x with the element e, followed by the remaining items xs, so (e:x) : xs is the first item. For the remaining items we recurse on the tail of the list xs and will for each sublist prepend this with the sublist x:
f e (x:xs) = ((e:x) : xs) : map (x:) (f e xs)
so putting these together gives us:
f :: a -> [[a]] -> [[[a]]]
f _ [] = []
f e (x:xs) = ((e : x) : xs) : map (x:) (f e xs)
Write splits which gives all possible ways of splitting a list
splits :: [a] -> [([a], [a])]
splits xs = zip (inits xs) (tails xs)
for example
> splits "abc"
[("","abc"),("a","bc"),("ab","c"),("abc","")]
and using it write a function that operates on each element of a list
onEach :: (a -> a) -> [a] -> [[a]]
onEach f xs = [ys ++ f z : zs | (ys, z:zs) <- splits xs]
like this
> onEach toUpper "abc"
["Abc","aBc","abC"]
and now f is just
f :: a -> [[a]] -> [[[a]]]
f x = onEach (x:)
Answer of David Flercher with onEach :: (a -> a) -> [a] -> [[a]] very interesting, I do some generalization with typeclass, I think this is usefull when we need some versions of objects mutated in one parameter..:
class Eachable e where
each :: (a -> a) -> e a -> [e a]
Now we can each on different types for example on Lists:
instance Eachable [] where
each _ [] = []
each g (x:xs) = ((g x) : xs) : map (x:) (each g xs)
each (+1) [1,2,3]
[[2,2,3],[1,3,3],[1,2,4]]
and Trees
data Tree a = Empty | Node (Tree a) a (Tree a) deriving Show
instance Eachable Tree where
each _ Empty = []
each g t#(Node l a r) = (\i -> e g 1 i t) <$> [1..count t] where
e _ _ _ Empty = Empty
e g c i (Node l a r) = Node l' a' r' where
a' = if c==i then g a else a
l' = if c==i then l else e g (c+1) i l
r' = if c==i then r else e g (c+(count l)+1) i r
count Empty = 0
count (Node l _ r) = 1 + count l + count r
tr = Node (Node Empty 1 Empty) 2 (Node Empty 3 Empty)
each (+1) tr
[Node (Node Empty 1 Empty) 3 (Node Empty 3 Empty),Node (Node Empty 2 Empty) 2 (Node Empty 3 Empty),Node (Node Empty 1 Empty) 2 (Node Empty 4 Empty)]
and others:
data Animal a = Animal {speed::a,size::a,smart::a} deriving Show
instance Eachable Animal where
each g (Animal sp sz sm) = [Animal (g sp) sz sm, Animal sp (g sz) sm, Animal sp sz (g sm)]
each (+1) $ Animal 1 1 1
[Animal {speed = 2, size = 1, smart = 1},Animal {speed = 1, size = 2, smart = 1},Animal {speed = 1, size = 1, smart = 2}]
Using Haskell:
Let's say I have list: [1,3,4,2,3]
And I want to modify all 3's in the list. I know that I can apply this to select the 3's in this case:
map (\x -> if p x then f x else x) xs
However, the functions being applied to the threes is dependent on their index within the list.
So for example if the index was added to the desired number the output of the function I'm going for would be: [1,4,4,2,7].
You can use zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] for this:
zipWith (\i x -> if p x then f i x else x) [0..] xs
where f thus takes i (the index) and x (the element) both into account.
For example:
zipWith (\i x -> if x == 3 then (i+x) else x) [0..] xs
Which generates the desired output:
Prelude> let xs = [1,3,4,2,3]
Prelude> zipWith (\i x -> if x == 3 then (i+x) else x) [0..] xs
[1,4,4,2,7]
You can encapsulate this logic into a separate function, for instance imap :: (Enum n, Num n) => (n -> a -> b) -> [a] -> b:
imap :: (Enum n, Num n) => (n -> a -> b) -> [a] -> b
imap = flip zipWith [0..]
This will work with any type that is an instance of Num and Enum (so Integer, Int, Float,...).
While zipWith is probably the right way, just for a variety you may go recursive as follows;
tpi :: [Int] -> [Int]
tpi = runner 0
where runner _ [] = []
runner n (x:xs) | x == 3 = (n + x) : runner (n+1) xs
| otherwise = x : runner (n+1) xs
I have this data structure for a tree:
data Tree a = NodeT a (Tree a) ( Tree a) | EmptyT
I need to create a function that returns a list of lists where each element of the list represents a level of the tree. For instance, from this:
1
/ \
2 3
/ \ / \
4 5 6 7
to this: [[1],[2,3],[4,5,6,7]]
The function must have the following form:
f :: Tree a -> [[a]]
How to do it using recursion?
anyone?
Thanks
Answer
levels :: Tree a -> [[a]]
levels t = levels' t []
levels' :: Tree a -> [[a]] -> [[a]]
levels' EmptyT rest = rest
levels' (NodeT a l r) [] = [a] : levels' l (levels r)
levels' (NodeT a l r) (x : xs) = (a : x) : levels' l (levels' r xs)
A slightly more complicated, but lazier, implementation of levels':
levels' EmptyT rest = rest
levels' (NodeT a l r) rest = (a : front) : levels' l (levels' r back)
where
(front, back) = case rest of
[] -> ([], [])
(x : xs) -> (x, xs)
Fans of folds will note that these are structured as catamorphisms:
cata :: (a -> b -> b -> b) -> b -> Tree a -> b
cata n e = go
where
go EmptyT = e
go (NodeT a l r) = n a (go l) (go r)
levels t = cata br id t []
where
br a l r rest = (a : front) : l (r back)
where
(front, back) = case rest of
[] -> ([], [])
(x : xs) -> (x, xs)
As chi points out, there seems to be some connection between this general approach and the result of using Jakub Daniel's solution with difference lists as intermediate forms. This could look something like
import Data.Monoid
levels :: Tree a -> [[a]]
levels = map (flip appEndo []) . (cata br [])
where
br :: a -> [Endo [a]] -> [Endo [a]] -> [Endo [a]]
br a l r = Endo (a :) : merge l r
merge :: Monoid a => [a] -> [a] -> [a]
merge [] ys = ys
merge (x : xs) ys = (x <> y) : merge xs ys'
where
(y,ys') =
case ys of
[] -> (mempty, [])
p : ps -> (p, ps)
I'm not entirely sure just how this compares with the more direct approaches.
Discussion
Kostiantyn Rybnikov's answer cites Okasaki's Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design, an excellent paper that highlights many functional programmers' "blind spots" and offers good arguments for making abstract data types easy enough to use that they won't be missed. However, the problem that paper describes is significantly more complex than this one; not so much machinery is required here. Also, the paper notes that level-oriented solutions are actually slightly faster than queue-based ones in ML; I'd expect to see a larger difference in a lazy language like Haskell.
Jakub Daniel's answer attempts a level-oriented solution, but unfortunately has an efficiency problem. It builds each level by repeatedly appending one list to another, and those lists may all be of equal length. Thus in the worst case, if I am calculating this correctly, it takes O(n log n) to process a tree with n elements.
The approach I chose is level-oriented, but avoids the pain of concatenation by passing each left subtree the levels of its right sibling and cousins. Each node/leaf of the tree is processed exactly once. That processing involves O(1) work: pattern matching on that node/leaf, and, if it is a node, pattern matching on the list derived from the right sibling and cousins. Thus the total time is O(n) to process a tree with n elements.
You recursively compute the levels and always merge lists from two subtrees point-wise (thus all the slices in the same depth get merged together).
f :: Tree a -> [[a]]
f EmptyT = []
f (NodeT a t1 t2) = [a] : merge (f t1) (f t2)
merge :: [[a]] -> [[a]] -> [[a]]
merge [] ys = ys
merge xs [] = xs
merge (x:xs) (y:ys) = (x ++ y) : merge xs ys
If the tree were complete (all the paths from the root to a list are of the same length) then you could use zipWith (++) as merge.
Slightly more complicated solution, than the one which was accepted, but I think mine might be better in terms of memory consumption (it's a bit late, so please check yourself).
Intuition goes from a wonderful paper of Chris Okasaki "Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design". You can get general intuition on breadth-first tree traversals of trees in functional languages in detail.
I did somewhat ugly addition to add the "list of lists" splitting, there might be a better way:
module Main where
data Tree a = NodeT a (Tree a) (Tree a) | EmptyT
-- 1
-- / \
-- 2 3
-- / \ / \
-- 4 5 6 7
f :: Tree a -> [[a]]
f t = joinBack (f' [(t, True)])
type UpLevel = Bool
f' :: [(Tree a, UpLevel)] -> [(a, UpLevel)]
f' [] = []
f' ((EmptyT, _) : ts) = f' ts
f' ((NodeT a t1 t2, up) : ts) = (a, up) : f' (ts ++ [(t1, up)] ++ [(t2, False)])
joinBack :: [(a, UpLevel)] -> [[a]]
joinBack = go []
where
go acc [] = [reverse acc]
go acc ((x, False) : xs) = go (x : acc) xs
go acc ((x, True) : xs) = reverse acc : go [] ((x, False):xs)
main :: IO ()
main = do
let tree = NodeT 1 (NodeT 2 (NodeT 4 EmptyT EmptyT) (NodeT 5 EmptyT EmptyT))
(NodeT 3 (NodeT 6 EmptyT EmptyT) (NodeT 7 EmptyT EmptyT))
:: Tree Int
print (tail (f tree))
Agda makes use of the following operator to show inverses between sets:
_↔_ : ∀ {f t} → Set f → Set t → Set _
Is there an equivalent in Idris? I'm trying to define bag equality on lists
data Elem : a -> List a -> Type where
Here : {xs : List a} -> Elem x (x :: xs)
There : {xs : List a} -> Elem x xs -> Elem x (y :: xs)
(~~) : List a -> List a -> Type
xs ~~ ys {a} = Elem a xs <-> Elem a ys
So that we can construct l1 ~~ l2 when l1 and l2 have the same elements in any order.
The Agda definition of ↔ seems to be very complicated and I am not sure if there is something equivalent in the Idris standard library.
The basic idea behind Agda's ↔ is to package up two functions with two proofs of roundtripping, which is easy enough to do in Idris as well:
infix 7 ~~
data (~~) : Type -> Type -> Type where
MkIso : {A : Type} -> {B : Type} ->
(to : A -> B) -> (from : B -> A) ->
(fromTo : (x : A) -> from (to x) = x) ->
(toFrom : (y : B) -> to (from y) = y) ->
A ~~ B
You can use it like in the following minimal example:
notNot : Bool ~~ Bool
notNot = MkIso not not prf prf
where
prf : (x : Bool) -> not (not x) = x
prf True = Refl
prf False = Refl
The reason the Agda version is more complicated is because it is parameterized over the choice of equality as well, so it doesn't have to be the propositional one (which is the strictest/finest there is). Parameterizing the Idris definition of ~~ above from = to arbitrary PA : A -> A -> Type and PB : B -> B -> Type is left as an exercise to the reader.
How would I combine the following 2 functions:
replaceNth n newVal (x:xs)
| n == 0 = newVal:xs
| otherwise = x:replaceNth (n-1) newVal xs
replaceMthNth m n v arg = replaceNth m (replaceNth n v (arg !! m)) arg
into a single function?
Is it possible?
This is pretty hideous but it does the job:
replacemn 0 0 z ((x : xs) : xss) = (z : xs) : xss
replacemn 0 n z ((x : xs) : xss) =
let (ys : yss) = replacemn 0 (n-1) z (xs : xss)
in ((x : ys) : yss)
replacemn m n z (xs:xss) = xs : replacemn (m-1) n z xss
Function composition
Functions in Haskell may be composed at no cost. E.g. given two functions, f and g, you can compose them into a new function: f . g, which applies g to an argument, then applies f to the result. You should be able to use composition in the same way here.
Ok, here it is with no other named functions in the global namespace, or using any where or let clauses or any other global functions.
{-# LANGUAGE ScopedTypeVariables,RankNTypes #-}
module Temp where
newtype Mu a = Mu (Mu a -> a)
replaceMthNth :: Int -> Int -> a -> [[a]] -> [[a]]
replaceMthNth = (\h (f :: Int -> forall b . b -> [b] -> [b]) -> h f f)
( \replaceNth replaceNth' ->
-- definition of replaceMthNth in terms of some replaceNth and replaceNth'
\m n v arg -> replaceNth m (replaceNth' n v (arg !! m)) arg
)
$
-- y combinator
((\f -> (\h -> h $ Mu h) $ \x -> f $ (\(Mu g) -> g) x $ x) :: (a -> a) -> a) $
(\replaceNth ->
-- definition of replaceNth given a recursive definition
(\(n::Int) newVal xs -> case xs of
[] -> []
(x:xs) -> if n == 0 then newVal:xs else x:replaceNth (n-1) newVal xs
)
)
I don't understand what the question is at all :), but here is how I would implement it:
modifyNth :: Int -> (a -> a) -> [a] -> [a]
modifyNth n f (x:xs)
| n == 0 = f x : xs
| otherwise = x : modifyNth (n-1) f xs
replaceNthMth :: Int -> Int -> a -> [[a]] -> [[a]]
replaceNthMth m n v = modifyNth m (modifyNth n (const v))
This way you don't need to traverse the list twice (first time with !!, second time with replaceNth)
Here's a grotesque implementation that rebuilds the 2d list structure with nested list comprehensions over zips with infinite lists:
replaceMthNth :: Int -> Int -> a -> [[a]] -> [[a]]
replaceMthNth m n v ass = [[if (x,y) == (m,n) then v else a
| (y, a) <- zip [0..] as]
| (x, as) <- zip [0..] ass]