Related
I needed to use lists for something I'm doing and needed look-up,
open import Data.List.Properties
open import Data.List
open import Data.Fin
infix 10 _‼_
_‼_ : ∀ {X : Set} → (xs : List X) → Fin (length xs) → X
[] ‼ ()
(x ∷ xs) ‼ fzero = x
(x ∷ xs) ‼ fsuc i = xs ‼ i
I had to define it myself since I could not find it in the libraries.
I wish the libraries where easier to navigate and search.
Any suggestions on better navigating or searching the libraries is much appreciated.
I wanted to show that look-ups on one argument of a concatenation is just lookup on the whole concatenation using a raised or injected index, namely
open import Relation.Binary.PropositionalEquality
‼-upper : ∀ {X} (pre main : List X) (i : Fin (length main))
→ let #pre+i = subst Fin (sym (length-++ pre)) (raise (length pre) i)in
(pre ++ main) ‼ #pre+i ≡ main ‼ i
‼-upper = ?
and dually
open import Data.Nat
open import Relation.Binary using
open DecTotalOrder decTotalOrder renaming (refl to ≤ℕ-refl ; trans to ≤ℕ-trans ; reflexive to ≤ℕ-reflexive)
open import Data.Nat.Properties
‼-lower : ∀ {X} (main pos : List X) (i : Fin (length main))
→ let i∶Fin#m++p = inject≤ i (≤ℕ-trans (m≤m+n _ (length pos) (≤ℕ-reflexive (sym (length-++ main)))) in
(main ++ pos) ‼ i∶Fin#m++p ≡ main ‼ i
‼-lower = {!!}
I originally proved these two for a variant of vectors, Fin n → X, and used pasting of such sequences in place of concatenation. Now I just want to do the same thing but for the usual List datatype. Any advice is appreciated.
Usually, when you have subst at the type level (which is a rather bad situation) you can eliminate it with rewrite at the value level. So let's try it:
‼-upper : ∀ {X} (pre main : List X) (i : Fin (length main))
→ let #pre+i = subst Fin (sym (length-++ pre)) (raise (length pre) i)in
(pre ++ main) ‼ #pre+i ≡ main ‼ i
‼-upper [] main i = refl
‼-upper (x ∷ pre) main i rewrite length-++ pre {main} = ?
Agda refuses:
w != foldr (λ _ → suc) 0 (pre ++ main) of type ℕ
when checking that the type
OK, something clashes with something. To remove this clashing we can instead rewrite by a "bigger" equation:
lem : ∀ {n m} (i : Fin n) (p : m ≡ n)
-> subst Fin (sym (cong suc p)) (fsuc i) ≡ fsuc (subst Fin (sym p) i)
lem i refl = refl
‼-upper : ∀ {X} (pre main : List X) (i : Fin (length main))
→ let #pre+i = subst Fin (sym (length-++ pre)) (raise (length pre) i)in
(pre ++ main) ‼ #pre+i ≡ main ‼ i
‼-upper [] main i = refl
‼-upper (x ∷ pre) main i rewrite lem (raise (length pre) i) (length-++ pre {main})
= ‼-upper pre main i
I guess ‼-lower is similar (also, it should be simpler if you replace inject≤ with inject+, see lookup-++-inject+ in Data.Vec.Properties). An alternative way is to define specialized versions of raise and inject:
raise-length : ∀ {α} {A : Set α}
-> (xs ys : List A) -> Fin (length ys) -> Fin (length (xs ++ ys))
raise-length [] ys i = i
raise-length (x ∷ xs) ys i = fsuc (raise-length xs ys i)
inject-length : ∀ {α} {A : Set α} {ys}
-> (xs : List A) -> Fin (length xs) -> Fin (length (xs ++ ys))
inject-length [] ()
inject-length (x ∷ xs) fzero = fzero
inject-length (x ∷ xs) (fsuc i) = fsuc (inject-length xs i)
‼-upper : ∀ {X} (pre main : List X) (i : Fin (length main))
-> (pre ++ main) ‼ raise-length pre main i ≡ main ‼ i
‼-upper [] main i = refl
‼-upper (x ∷ pre) main i = ‼-upper pre main i
‼-lower : ∀ {X} (main pos : List X) (i : Fin (length main))
-> (main ++ pos) ‼ inject-length main i ≡ main ‼ i
‼-lower [] pos ()
‼-lower (x ∷ main) pos fzero = refl
‼-lower (x ∷ main) pos (fsuc i) = ‼-lower main pos i
But I would simply use some form of vectors — why complicate your life?
I'm playing with a formalisation of a certified regular expression matcher in Idris (I believe that the same problem holds in any type theory based proof assistant, such as Agda and Coq) and I'm stuck on how to define semantics of the complement operation. I have the following data type to represent semantics of regular expressions:
data InRegExp : List Char -> RegExp -> Type where
InEps : InRegExp [] Eps
InChr : InRegExp [ a ] (Chr a)
InCat : InRegExp xs l ->
InRegExp ys r ->
zs = xs ++ ys ->
InRegExp zs (Cat l r)
InAltL : InRegExp xs l ->
InRegExp xs (Alt l r)
InAltR : InRegExp xs r ->
InRegExp xs (Alt l r)
InStar : InRegExp xs (Alt Eps (Cat e (Star e))) ->
InRegExp xs (Star e)
InComp : Not (InRegExp xs e) -> InRegExp xs (Comp e)
My problem is to represent the type of InComp constructor since it has a non-strictly positive occurrence of InRegExp due to the usage of Not. Since such data types can be used to define non-terminating functions, they are rejected by terminations checker. I would like to define such semantics in a way that it is accepted by Idris termination checker.
Is there some way that could I represent semantics of complement operation without have negative occurrences of InRegExp?
You can define InRegex by recursion on Regex. In that case, strict positivity is no issue, but we have to recurse structurally:
import Data.List.Quantifiers
data Regex : Type where
Chr : Char -> Regex
Eps : Regex
Cat : Regex -> Regex -> Regex
Alt : Regex -> Regex -> Regex
Star : Regex -> Regex
Comp : Regex -> Regex
InRegex : List Char -> Regex -> Type
InRegex xs (Chr x) = xs = x :: []
InRegex xs Eps = xs = []
InRegex xs (Cat r1 r2) = (ys ** (zs ** (xs = ys ++ zs, InRegex ys r1, InRegex zs r2)))
InRegex xs (Alt r1 r2) = Either (InRegex xs r1) (InRegex xs r2)
InRegex xs (Star r) = (yss ** (All (\ys => InRegex ys r) yss, xs = concat yss))
InRegex xs (Comp r) = Not (InRegex xs r)
We would need an inductive type for the Star case if we wanted to use our old definition. The following obviously doesn't work:
InRegex xs (Star r) = InRegex (Alt Eps (Cat r (Star r)))
However, we can just simply change the definition and make finiteness explicit:
InRegex xs (Star r) = (yss ** (All (\ys => InRegex ys r) yss, xs = concat yss))
This has the intended meaning and I don't see any drawbacks to it.
You could mutually define NotInRegExp which would explain what it means to not be recognised by a regexp (I haven't checked whether this is valid syntax).
data NotInRegExp : List Char -> RegExp -> Type where
NotInEps : Not (xs = []) -> NotInRegExp xs Eps
NotInChr : Not (xs = [ a ]) -> NotInRegExp xs (Chr a)
NotInCat : (forall xs ys, zs = xs ++ ys ->
NotInRegExp xs l
+ InRegExp xs l * NotInRegExp ys r) ->
NotInRegExp zs (Cat l r)
etc...
You should then be able to define a nice decision procedure:
check : (xs : List Char) (e : RegExp) -> Either (InRegexp xs e) (NotInRegexp xs e)
You could also define this type by recursion on the RegExp plus some inductive datatype for the semantics of Star.
I guess it wouldn't interact as nicely with the built-in pattern matching but it would have the same induction principle.
Given the following function:
let rec foo l1 l2 =
match (l1,l2) with
([],ys) -> ys
| (x::xs,ys) -> foo xs (x::ys))
Prove the following property:
foo (foo xs ys) zs = foo ys (xs#zs)
So far, I have completed the base case and inductive case, but have no idea how to start the proof:
Base Case:
foo (foo [] ys) zs = foo ys ([]#zs)
foo ys zs = foo ys zs
Inductive Case:
foo (foo (x::xs) ys) zs = foo ys ((x::xs)#zs)
An outline of the kind of proof you are asking about follows. I included the base case. The inductive case is left for you. Make sure you use the assumption mentioned in the outline somewhere in the inductive case to complete it. I am using = for "equality" and => for evaluation. I don't know what relations are available in your context, what you are allowed to assume about evaluation and equality, or whether you are allowed to use lemmas about # or have an abstract definition available. So, you will likely have to modify this.
Proof by induction on the structure of xs.
Case: xs = []:
foo (foo xs ys) zs
= foo (foo [] ys) zs (* structure of xs *)
=> foo (match ([], ys) with ([], ys) -> ys | (* ... *)
(* def. of foo, substitution *)
=> foo (ys) zs (* eval. of match *)
= foo ys zs (* drop parentheses *)
= foo ys ([] # zs) (* abstract def. of # *)
= foo ys (xs # zs) (* structure of xs *)
Case: xs = x::xs':
Here, suppose that, for all ys, zs, foo (foo xs' ys) zs = foo ys (xs' # zs). (This is the so-called inductive hypothesis.)
foo (foo xs ys) zs
= foo (foo (x::xs') ys) zs (* structure of xs *)
= foo (match (x::xs', ys) with (* ... *) | (x::xs', ys) -> (* ... *)
(* def. of foo, substitution *)
=> foo (foo xs' (x::ys)) zs (* eval. of match *)
(* for you *)
= foo ys ((x::xs') # zs) (* by some argument from you *)
= foo ys (xs # zs) (* structure of xs *)
As you can see, the proof starts by picking a value to do structural induction on (you already picked xs in your question). Then, the proof splits into cases according to all the possible ways xs might be constructed. Since xs is presumably a list (this is why type information is important), there are only two kinds of things it could be: it might be [], or it might be x::xs' for some value x and list xs'. This results in the base case and the inductive case, respectively. In both cases, we have to prove the same original property, but we know extra information about what xs looks like (i.e., the "structure" of xs).
For each case, you use the structure to figure out the statement you want to get to (approximately correct in your original question). Then, you try to simply go from the expression on the left side of the statement to the expression on the right side, using the rules of evaluation, identity, and any lemmas you have available. In the inductive case, you have an additional fact you can use about xs' (the "inductive hypothesis"). This "direct" approach isn't going to work in all (perhaps most) cases at the level of research, but it works fine for this exercise.
The actual statements proved in the cases are
If xs = [], foo (foo xs ys) zs = foo ys (xs # zs); and
If xs = x::xs' and foo (foo xs' ys) zs = foo ys (xs' # zs), then foo (foo xs ys) zs = foo ys (xs # zs).
ys and zs are implicitly universally quantified.
Claim: forall xs, ys, zs, foo (foo xs ys) zs = foo ys (xs#zs)
Proof: By induction on xs
P(xs): forall ys, zs, foo (foo xs ys) zs = foo ys (xs#zs)
P([]): forall ys, zs, foo (foo [] ys) zs = foo ys ([]#zs)
LHS:
= foo (foo [] ys) zs
= foo (ys) zs
= foo ys zs
RHS:
= foo ys ([]#zs)
= foo ys zs {eval #}
= LHS
IC: xs=h::t
IH: P(t): forall ys, zs, foo (foo t ys) zs = foo ys (t#zs)
Show: P(h::t): forall ys, zs, foo (foo h::t ys) zs = foo ys (h::t#zs)
LHS:
= foo (foo h::t ys) zs
= foo (foo t (h::ys)) zs
= foo (h::ys) (t#zs) {IH with ys:=h::ys}
= foo ys (h::t#zs) {eval of foo}
= RHS
RHS:
= foo ys (h::t#zs)
= LHS
QED
How to implement insert using foldr in haskell.
I tried:
insert'' :: Ord a => a -> [a] -> [a]
insert'' e xs = foldr (\x -> \y -> if x<y then x:y else y:x) [e] xs
No dice.
I have to insert element e in list so that it goes before first element that is larger or equal to it.
Example:
insert'' 2.5 [1,2,3] => [1.0,2.0,2.5,3.0]
insert'' 2.5 [3,2,1] => [2.5,3.0,2.0,1.0]
insert'' 2 [1,2,1] => [1,2,2,1]
In last example first 2 is inserted one.
EDIT:
Thanks #Lee.
I have this now:
insert'' :: Ord a => a -> [a] -> [a]
insert'' e xs = insert2 e (reverse xs)
insert2 e = reverse . snd . foldr (\i (done, l) -> if (done == False) && (vj e i) then (True, e:i:l) else (done, i:l)) (False, [])
where vj e i = e<=i
But for this is not working:
insert'' 2 [1,3,2,3,3] => [1,3,2,2,3,3]
insert'' 2 [1,3,3,4] => [1,3,2,3,4]
insert'' 2 [4,3,2,1] => [4,2,3,2,1]
SOLUTION:
insert'' :: Ord a => a -> [a] -> [a]
insert'' x xs = foldr pom poc xs False
where
pom y f je
| je || x > y = y : f je
| otherwise = x : y : f True
poc True = []
poc _ = [x]
Thanks #Pedro Rodrigues (It just nedded to change x>=y to x>y.)
(How to mark this as answered?)
You need paramorphism for that:
para :: (a -> [a] -> r -> r) -> r -> [a] -> r
foldr :: (a -> r -> r) -> r -> [a] -> r
para c n (x : xs) = c x xs (para c n xs)
foldr c n (x : xs) = c x (foldr c n xs)
para _ n [] = n
foldr _ n [] = n
with it,
insert v xs = para (\x xs r -> if v <= x then (v:x:xs) else (x:r)) [v] xs
We can imitate paramorphisms with foldr over init . tails, as can be seen here: Need to partition a list into lists based on breaks in ascending order of elements (Haskell).
Thus the solution is
import Data.List (tails)
insert v xs = foldr g [v] (init $ tails xs)
where
g xs#(x:_) r | v <= x = v : xs
| otherwise = x : r
Another way to encode paramorphisms is by a chain of functions, as seen in the answer by Pedro Rodrigues, to arrange for the left-to-right information flow while passing a second copy of the input list itself as an argument (replicating the effect of tails):
insert v xs = foldr g (\ _ -> [v]) xs xs
where
g x r xs | v > x = x : r (tail xs) -- xs =#= (x:_)
| otherwise = v : xs
-- visual aid to how this works, for a list [a,b,c,d]:
-- g a (g b (g c (g d (\ _ -> [v])))) [a,b,c,d]
Unlike the version in his answer, this does not copy the rest of the list structure after the insertion point (which is possible because of paramorphism's "eating the cake and having it too").
Here's my take at it:
insert :: Ord a => a -> [a] -> [a]
insert x xs = foldr aux initial xs False
where
aux y f done
| done || x > y = y : f done
| otherwise = x : y : f True
initial True = []
initial _ = [x]
However IMHO using foldr is not the best fit for this problem, and for me the following solution is easier to understand:
insert :: Int -> [Int] -> [Int]
insert x [] = [x]
insert x z#(y : ys)
| x <= y = x : z
| otherwise = y : insert x ys
I suppose fold isn't handy here. It always processes all elements of list, but you need to stop then first occurence was found.
Of course it is possible, but you probable don't want to use this:
insert' l a = snd $ foldl (\(done, l') b -> if done then (True, l'++[b]) else if a<b then (False, l'++[b]) else (True, l'++[a,b])) (False, []) l
I have a function for finite lists
> kart :: [a] -> [b] -> [(a,b)]
> kart xs ys = [(x,y) | x <- xs, y <- ys]
but how to implement it for infinite lists? I have heard something about Cantor and set theory.
I also found a function like
> genFromPair (e1, e2) = [x*e1 + y*e2 | x <- [0..], y <- [0..]]
But I'm not sure if it helps, because Hugs only gives out pairs without ever stopping.
Thanks for help.
Your first definition, kart xs ys = [(x,y) | x <- xs, y <- ys], is equivalent to
kart xs ys = xs >>= (\x ->
ys >>= (\y -> [(x,y)]))
where
(x:xs) >>= g = g x ++ (xs >>= g)
(x:xs) ++ ys = x : (xs ++ ys)
are sequential operations. Redefine them as alternating operations,
(x:xs) >>/ g = g x +/ (xs >>/ g)
(x:xs) +/ ys = x : (ys +/ xs)
[] +/ ys = ys
and your definition should be good to go for infinite lists as well:
kart_i xs ys = xs >>/ (\x ->
ys >>/ (\y -> [(x,y)]))
testing,
Prelude> take 20 $ kart_i [1..] [101..]
[(1,101),(2,101),(1,102),(3,101),(1,103),(2,102),(1,104),(4,101),(1,105),(2,103)
,(1,106),(3,102),(1,107),(2,104),(1,108),(5,101),(1,109),(2,105),(1,110),(3,103)]
courtesy of "The Reasoned Schemer". (see also conda, condi, conde, condu).
another way, more explicit, is to create separate sub-streams and combine them:
kart_i2 xs ys = foldr g [] [map (x,) ys | x <- xs]
where
g a b = head a : head b : g (tail a) (tail b)
this actually produces exactly the same results. But now we have more control over how we combine the sub-streams. We can be more diagonal:
kart_i3 xs ys = g [] [map (x,) ys | x <- xs]
where -- works both for finite
g [] [] = [] -- and infinite lists
g a b = concatMap (take 1) a
++ g (filter (not . null) (take 1 b ++ map (drop 1) a))
(drop 1 b)
so that now we get
Prelude> take 20 $ kart_i3 [1..] [101..]
[(1,101),(2,101),(1,102),(3,101),(2,102),(1,103),(4,101),(3,102),(2,103),(1,104)
,(5,101),(4,102),(3,103),(2,104),(1,105),(6,101),(5,102),(4,103),(3,104),(2,105)]
With some searching on SO I've also found an answer by Norman Ramsey with seemingly yet another way to generate the sequence, splitting these sub-streams into four areas - top-left tip, top row, left column, and recursively the rest. His merge there is the same as our +/ here.
Your second definition,
genFromPair (e1, e2) = [x*e1 + y*e2 | x <- [0..], y <- [0..]]
is equivalent to just
genFromPair (e1, e2) = [0*e1 + y*e2 | y <- [0..]]
Because the list [0..] is infinite there's no chance for any other value of x to come into play. This is the problem that the above definitions all try to avoid.
Prelude> let kart = (\xs ys -> [(x,y) | ls <- map (\x -> map (\y -> (x,y)) ys) xs, (x,y) <- ls])
Prelude> :t kart
kart :: [t] -> [t1] -> [(t, t1)]
Prelude> take 10 $ kart [0..] [1..]
[(0,1),(0,2),(0,3),(0,4),(0,5),(0,6),(0,7),(0,8),(0,9),(0,10)]
Prelude> take 10 $ kart [0..] [5..10]
[(0,5),(0,6),(0,7),(0,8),(0,9),(0,10),(1,5),(1,6),(1,7),(1,8)]
you can think of the sequel as
0: (0, 0)
/ \
1: (1,0) (0,1)
/ \ / \
2: (2,0) (1, 1) (0,2)
...
Each level can be expressed by level n: [(n,0), (n-1, 1), (n-2, 2), ..., (0, n)]
Doing this to n <- [0..]
We have
cartesianProducts = [(n-m, m) | n<-[0..], m<-[0..n]]