I am very new to Haskell and I wrote a Data Type in Haskell
for representing an interval map.
What does that mean? Briefly: A map data type that gives you a value back
for every possible key (put simply in my case [0..]).
Then you insert "sequences" like I want my map to hold from 7 to 23 'b'
so keys 0 to 6 will be init value e.g. 'a' and 7 to 23 will be 'b' and 24 and ongoing will be 'a' again etc.
I managed to wrote the Data Type, a get and insert function as well as a
functor version.
But I can't managed to get a applicative functor version to work.
The idea is to set the keys value to [0..] and just work on the values.
Here is my code and thanks for any provided help!
-- Building an interval map data structure in haskell
data IntervalMap k v = IntervalMap {keys :: [k] , values :: [v]} | Empty deriving Show
-- k = key, Typ variable
-- v = value, Typ variable
singleton :: (Enum k, Num k) => v -> IntervalMap k v
singleton v = IntervalMap{keys=[0..], values= repeat v}
-- get operator => a ! 5 = value at position 5
(!) :: Ord k => IntervalMap k v -> k -> v
(!) iMap k = snd (head (filter (\(x, y) -> x == k) (zip (keys iMap) (values iMap)) ))
-- insert a sequence into intervalMap
insert :: (Ord k, Num k, Enum k) => k -> k -> v -> IntervalMap k v -> IntervalMap k v
insert start end value iMap = IntervalMap {keys=keys iMap, values = rangeChanger (values iMap) start end value}
-- helper function to change a range of values in an intervalMap
rangeChanger :: (Num a1, Enum a1, Ord a1) => [a2] -> a1 -> a1 -> a2 -> [a2]
rangeChanger iMapValues start end value = [if (i >= start) && (i <= end) then newValue else iMapValue | (iMapValue, newValue, i) <- zip3 iMapValues (repeat value) [0..]]
-- functor instance for intervalMap
instance Functor (IntervalMap k) where
-- fmap :: (a -> b) -> f a -> f b
fmap f iMap = IntervalMap {keys=keys iMap, values= map f (values iMap) }
-- applicative functor for intervalMap
instance (Ord k, Num k, Enum k) => Applicative (IntervalMap k) where
pure k = IntervalMap{keys=[0..], values=repeat k}
_ <*> Nothing = Nothing
-- HOW TO DO?
-- class Functor functor => Applicative functor where
-- pure :: a -> functor a
-- (<*>) :: functor (a -> b) -> functor a -> functor b
-- (*>) :: functor a -> functor b -> functor b
-- (<*) :: functor a -> functor b -> functor a
It seems like you always expect the keys to be [0..], e.g. it is hard-coded in your rangeChanger function. If that is the case then it is redundant and honestly I would leave it out. You can easily reconstruct it by doing something like zip [0..] (values iMap) as you do in the rangeChanger function.
If you make that change, then your IntervalMap data structure is basically the same as ZipList which has an applicative instance here:
instance Applicative ZipList where
pure x = ZipList (repeat x)
liftA2 f (ZipList xs) (ZipList ys) = ZipList (zipWith f xs ys)
You see that this doesn't define a <*> but that can be defined in terms of liftA2: p <*> q = liftA2 (\f x -> f x) p q, so you could also write that explicitly for ZipList:
ZipList fs <*> ZipList xs = ZipList (zipWith (\f x -> f x) fs xs)
Edit: I should also mention that one difference with ZipList is that you have an Empty constructor for your IntervalMap type. That makes things harder, you would need to know that your values have some sort of default value, but that is not possible in general (not every type has a default value), so your type cannot be an Applicative. Do you really need that Empty case?
Context: I have been trying to implement the unification algorithm (the algorithm to find the most general unifier of two abstract syntax trees). Since a unifier is a substitution, algorithm requires defining composition of substitutions.
To be specific, given a type treeSigma dependent on another type X, a substitution is a function of type:
X -> treeSigma X
and the function substitute takes a substitution as an input and has type
substitute: (X-> (treeSigma X))-> (treeSigma X) -> (treeSigma X)
I need to define a function to compose two substitutions:
compose_kleisli (rho1 rho2: X->(treeSigma X)) : (treeSigma X) := ...
such that,
forall tr: treeSigma X,
substitute (compose_kleisli rho1 rho2) tr = substitute rho1 (substitute rho2 tr).
I am fairly new to coq and have been stuck with defining this composition.
How can I define this composition?
I tried to define it using Record like this:
Record compose {X s} (rho1 rho2: X-> treeSigma X):= mkCompose{
RHO: X-> treeSigma X;
CONDITION: forall t, substitute RHO t = substitute rho2 (substitute rho1 t)
}.
but along with this, I would need to prove the result that the composition can be defined for any two substitutions. Something like:
Theorem composeTotal: forall {X s} (rho1 rho2: X-> treeSigma s X), exists rho3,
forall t, substitute rho3 t = substitute rho2 (substitute rho1 t).
Proving this would require a construction of rho3 which circles back to the same problem of defining compose.
treeSigma is defined as:
(* Signature *)
Record sigma: Type := mkSigma {
symbol : Type;
arity : symbol -> nat
}.
Record sigmaLeaf (s:sigma): Type := mkLeaf {
cLeaf: symbol s;
condLeaf: arity s cLeaf = 0
}.
Record sigmaNode (s:sigma): Type := mkNode {
fNode: symbol s;
condNode: arity s fNode <> 0
}.
(* Sigma Algebra *)
Record sigAlg (s:sigma) (X:Type) := mkAlg {
Carrier: Type;
meaning: forall f:(sigmaNode s), (Vector.t Carrier (arity s (fNode s f))) -> Carrier;
meanLeaf: forall f:(sigmaLeaf s), Vector.t Carrier 0 -> Carrier
}.
(* Abstract tree on arbitrary signature. *)
Inductive treeSigma (s:sigma) (X:Type):=
| VAR (x:X)
| LEAF (c: sigmaLeaf s)
| NODE (f: sigmaNode s) (sub: Vector.t (treeSigma s X) (arity s (fNode s f)) ).
(* Defining abstract syntax as a sigma algebra. *)
Definition meanTreeNode {s X} (f:sigmaNode s) (sub: Vector.t (treeSigma s X) (s.(arity)
(fNode s f))): treeSigma s X:= NODE s X f sub.
Definition meanTreeLeaf {s X} (c:sigmaLeaf s) (sub: Vector.t (treeSigma s X) 0) := LEAF s X c.
Definition treeSigAlg {s X} := mkAlg s X (treeSigma s X) meanTreeNode meanTreeLeaf.
The substitution function is defined as:
Fixpoint homoSigma1 {X:Type} {s} (A: sigAlg s X) (rho: X-> (Carrier s X A))
(wft: (treeSigma s X)) {struct wft}: (Carrier s X A) :=
match wft with
| VAR _ _ x => rho x
| LEAF _ _ c => meanLeaf s X A c []
| NODE _ _ f l2 => meanNode s X A f (
(fix homoSigVec k (l2:Vector.t _ k):= match l2 with
| [] => []
| t::l2s => (homoSigma1 A rho t):: (homoSigVec (vlen _ l2s) l2s)
end)
(arity s (fNode s f)) l2)
end.
Definition substitute {X s} (rho: X-> treeSigma s X) (t: treeSigma s X) := #homoSigma1 X s treeSigAlg rho t.
To be particular, a substitution is the homomorphic extension of rho (which is a variable valuation).
Definitions like this are challenging to work with because the tree type occurs recursively inside of another inductive type. Coq has trouble generating induction principles for these types on its own, so you need to help it a little bit. Here is a possible solution, for a slightly simplified set up:
Require Import Coq.Vectors.Vector.
Import VectorNotations.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Section Dev.
Variable symbol : Type.
Variable arity : symbol -> nat.
Record alg := Alg {
alg_sort :> Type;
alg_op : forall f : symbol, Vector.t alg_sort (arity f) -> alg_sort;
}.
Arguments alg_op {_} f _.
(* Turn off the automatic generation of induction principles.
This tree type does not distinguish between leaves and nodes,
since they only differ in their arity. *)
Unset Elimination Schemes.
Inductive treeSigma (X:Type) :=
| VAR (x:X)
| NODE (f: symbol) (args : Vector.t (treeSigma X) (arity f)).
Arguments NODE {X} _ _.
Set Elimination Schemes.
(* Manual definition of a custom induction principle for treeSigma.
HNODE is the inductive case for the NODE constructor; the vs argument is
saying that the induction hypothesis holds for each tree in the vector of
arguments. *)
Definition treeSigma_rect (X : Type) (T : treeSigma X -> Type)
(HVAR : forall x, T (VAR x))
(HNODE : forall f (ts : Vector.t (treeSigma X) (arity f))
(vs : Vector.fold_right (fun t V => T t * V)%type ts unit),
T (NODE f ts)) :
forall t, T t :=
fix loopTree (t : treeSigma X) : T t :=
match t with
| VAR x => HVAR x
| NODE f ts =>
let fix loopVector n (ts : Vector.t (treeSigma X) n) :
Vector.fold_right (fun t V => T t * V)%type ts unit :=
match ts with
| [] => tt
| t :: ts => (loopTree t, loopVector _ ts)
end in
HNODE f ts (loopVector (arity f) ts)
end.
Definition treeSigma_ind (X : Type) (T : treeSigma X -> Prop) :=
#treeSigma_rect X T.
Definition treeSigma_alg (X:Type) : alg := {|
alg_sort := treeSigma X;
alg_op := #NODE X;
|}.
Fixpoint homoSigma {X : Type} {Y : alg} (ρ : X -> Y) (t : treeSigma X) : Y :=
match t with
| VAR x => ρ x
| NODE f xs => alg_op f (Vector.map (homoSigma ρ) xs)
end.
Definition substitute X (ρ : X -> treeSigma X) (t : treeSigma X) : treeSigma X :=
#homoSigma X (treeSigma_alg X) ρ t.
(* You can define composition simply by applying using substitution. *)
Definition compose X (ρ1 ρ2 : X -> treeSigma X) : X -> treeSigma X :=
fun x => substitute ρ1 (ρ2 x).
(* The property you are looking for follows by induction on the tree. Note
that this requires a nested induction on the vector of arguments. *)
Theorem composeP X (ρ1 ρ2 : X -> treeSigma X) t :
substitute (compose ρ1 ρ2) t = substitute ρ1 (substitute ρ2 t).
Proof.
unfold compose, substitute.
induction t as [x|f ts IH]; trivial.
simpl; f_equal.
induction ts as [|n t ts IH']; trivial.
simpl.
destruct IH as [e IH].
rewrite e.
f_equal.
now apply IH'.
Qed.
End Dev.
In order to do this you need to use the operations of the monad, typically:
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Section MonadKleisli.
(* Set Universe Polymorphism. // Needed for real use cases *)
Variable (M : Type -> Type).
Variable (Ma : forall A B, (A -> B) -> M A -> M B).
Variable (η : forall A, A -> M A).
Variable (μ : forall A, M (M A) -> M A).
(* Compose: o^* *)
Definition oStar A B C (f : A -> M B) (g: B -> M C) : A -> M C :=
fun x => μ (Ma g (f x)).
(* Bind *)
Definition bind A B (x : M A) (f : A -> M B) : M B := oStar (fun _ => x) f tt.
End MonadKleisli.
Depending on how you organize your definitions, proving your desired properties will likely require functional extensionality, not a big deal usually but something to keep in ind.
I´m trying to learn more about dependent types using IDRIS.
The example I am trying to emulate uses composition of Vectors.
I understand Functor and Applicative implementations for Vectors but I am struggling to implement them for the Composition.
data Vector : Nat -> Type -> Type where
Nil : Vector Z a
(::) : a -> Vector n a -> Vector (S n) a
Functor (Vector n) where
map f [] = []
map f (x::xs) = f x :: map f xs
Applicative (Vector n) where
pure = replicate _
fs <*> vs = zipWith apply fs vs
Now the Composition and Decomposition-Function look like this:
data (:++) : (b -> c) -> (a -> b) -> a -> Type where
Comp : (f . g) x -> (f :++ g) x
unComp : (f :++ g) a -> (f . g) a
unComp (Comp a) = a
User with Vectors it encapsulates a Vector of Vectors.
Now I need an Applicative for the Composition (Vector n) :++ (Vector n).
I can´t even get Functor to work and am mainly trying to see what I´m doing wrong. I tried the following and, since Functor is already implemented for Vectors, that this would work
Functor ((Vector n) :++ (Vector n)) where
map f (Comp []) = Comp []
map f (Comp (x::xs)) = Comp ((f x) :: (map f (Comp xs)))
but the Compiler gives an Error-Message:
When checking an application of constructor Main.:::
Unifying a and Vector (S n) a would lead to infinite value
Isn´t unifying and element of type a and a Vector n a exactly the purpose of (::)?
I am obviously doing something wrong and I can´t get this to work. I also have the feeling it´s probably easy to solve, but after hours of reading and trying I still don´t get it.
If someone could give me advice or explain to me how the Functor and Applicative implementations could look like, I would be very grateful.
Update: Idris 2 now has this builtin. Functor for Compose, Applicative for Compose
I think you can implement a general instance of Functor and Applicative like with Haskell's Compose.
newtype Compose f g a = Compose { getCompose :: f (g a) }
instance (Functor f, Functor g) => Functor (Compose f g) where
fmap f (Compose x) = Compose (fmap (fmap f) x)
a <$ (Compose x) = Compose (fmap (a <$) x)
instance (Applicative f, Applicative g) => Applicative (Compose f g) where
pure x = Compose (pure (pure x))
Compose f <*> Compose x = Compose (liftA2 (<*>) f x)
liftA2 f (Compose x) (Compose y) =
Compose (liftA2 (liftA2 f) x y)
To answer your specific question (but don't do it this way):
Functor ((Vector n) :++ (Vector n)) where
map f (Comp x) = Comp $ map (map f) x
I'm trying to find the mode or value that occurs most frequently. I want a function like :
mode:' 'a list -> (''a * int) list
and it returns the mode and where it occurs, unless there is a tie then return all occurrences so something like:
mode([1,1,2,3,5,8]) ===> [(1,2)]
mode([1,3,5,2,3,5]) ===> [(3,2),(5,2)]
mode([true,false,true,true]) ====>[(true,3)]
I'm trying to do this without library functions in SML.
so far I got:
fun mode(L)=
if null L then nil
else if hd L= hd (tl L) then 1+mode(hd(tl L))
else mode(tl L);
I know this isn't right I guess I am curious on how you both keep the indices of where the mode occurs and what the mode is and return them as tuples in a list.
You're trying to solve an exercise in many parts with several easier exercises before it. Judging by your current progress, have you considered solving some very similar exercises that build up to the final goal? This is generally good advice when solving programming problems: Reduce your current problem to simpler problems and solve those.
I'd try and solve this problem first
Build a histogram : ''a list -> (''a * int) list over the elements of a list:
fun histogram [] = ...
| histogram (x::xs) = ...
Do this by inserting each x with its count into a histogram.
fun insert (x, []) = ...
| insert (x, (y, count) :: hist) = ...
And write some tests that you can execute once in a while.
Find the mode : ''a list -> ''a of a list:
fun mode xs = ... (histogram xs)
Do this by finding the element in the histogram with the biggest count:
fun findMax [] = ... (* what if the list/histogram is empty? *)
| findMax [(x, count)] = ...
| findMax ((x, count) :: (y, count) :: hist) = ...
and eventually try and solve this problem
When you have a good grasp of representing and navigating regular histograms recursively, you could create an annotated histogram : (''a * int * int list) list that doesn't just contain the frequency of each element, but also their positions in the input list:
fun histogram_helper ([], _) = ...
| histogram_helper (x::xs, i) = ... histogram_helper (xs, i+1) ...
Do this by inserting each x with its count and position i along with previously found positions is into a histogram:
fun insert (x, i, []) = ...
| insert (x, i, (y, count, is) :: hist) = ...
Find the (possibly multiple) mode : ''a list -> (''a * int list) list of a list:
fun mode xs = ... (histogram xs)
Do this by finding the (possibly multiple) element(s) in the histogram with the biggest count:
fun findMax ([], countMax, tmpModes) = ...
| findMax ((x, count, is) :: hist, countMax, tmpModes) = ...
with countMax : int being the frequency repeated in tmpModes : (''a * int * int list) list. Here countMax and tmpModes are accumulating result parameters. Do this by determining whether (x, count, is) should be thrown away in favor of all tmpModes, or it should be added to tmpModes, or it should be chosen in favor of all tmpNodes
I am curious on how you both keep the indices of where the mode occurs and what the mode is and return them as tuples in a list.
Yes, this is not trivial. Using my suggested division into sub-problems, answering this depends on whether we are in the histogram function or the findMax function:
In histogram you can store the indices as part of the tuple that contains the element and the frequency. In findMax, since you're potentially collecting multiple results, you need to keep track of both which frequency is the highest (countMax) and what the temporary modes of choice are (tmpModes); subject to replacement or addition in a later recursive call.
So to answer your question: In an accumulating parameter.
and a little feedback to your code snippet
fun mode(L)=
if null L then nil
else if hd L= hd (tl L) then 1+mode(hd(tl L))
else mode(tl L);
Use pattern matching instead of null, hd and tl:
fun count_4s [] = 0
| count_4s (x::xs) = (if x = 4 then 1 else 0) + count_4s xs
fun count_ns ([], _) = 0
| count_ns (x::xs, n) = (if x = n then 1 else 0) + count_ns (xs, n)
fun count_12 ([], ones, twos) = (ones, twos)
| count_12 (x::xs, ones, twos) =
if x = 1 then count_12 (xs, ones+1, twos) else
if x = 2 then count_12 (xs, ones, twos+1) else
count_12 (xs, ones, twos)
fun count_abc ([], result) = result
| count_abc (x::xs, ((a, ca), (b, cb), (c, cc))) =
count_abc (xs, if x = a then ((a, ca+1), (b, cb), (c, cc)) else
if x = b then ((a, ca), (b, cb+1), (c, cc)) else
if x = c then ((a, ca), (b, cb), (c, cc+1)) else
((a, ca), (b, cb), (c, cc)))
Building a histogram is sort of an extension to this where instead of a fixed value like 4, or a fixed amount of them like ones and twos, you have a whole list of them, and you have to dynamically look for the one you've got, x, and determine if it needs to be added to the histogram or incremented in the histogram.
The best way would be to do that in a helper function, so for example, if count_abc were made with a helper function,
fun insert_abc (x, ((a, ca), (b, cb), (c, cc))) =
if x = a then ((a, ca+1), (b, cb), (c, cc)) else
if x = b then ((a, ca), (b, cb+1), (c, cc)) else
if x = c then ((a, ca), (b, cb), (c, cc+1)) else
((a, ca), (b, cb), (c, cc)))
fun count_abc ([], result) = result
| count_abc (x::xs, result) =
count_abc (xs, insert (x, result))
only instead of the histogram representation
(''a * int) * (''a * int) * (''a * int)
you want
(''a * int) list
and insert should be recursive rather than how insert_abc is repetitive.
I created a function and helper function that find the number of repeating elements in a list, and what those elements.
let rec _encode l x =
match l with
| [] -> 0
| head::rest -> (if head = x then 1 else 0) + encode rest x
let encode l x = ((_encode l x), x)
In this case, I have to specify what that element is for it to search.
So this is a two part question. 1) How do I do it to return a list of tuples, with format (int * 'a) list, where int is the # of rep, and 'a is the element that is repeating.
2) How would I implement this using fold_right?
I was thinking something along the lines of:
let encode (l : 'a list) : (int * 'a) list = fold_right (fun (x,hd) lst ->
match x with
| [] -> 0
| hd :: rest -> if hd x then (x+1, hd) else (x, hd)) l []
Your attempt looks very confused:
It doesn't use lst, hd (the first one), or rest.
x is used as a list (match x with []) and a number (x+1).
The elements of x (list) are functions that return bools?? (... hd::rest -> ... if hd x)
The function sometimes returns a number (0) and sometimes a tuple ((x, hd)).
Here's how I'd do it:
let encode l =
let f x = function
| (n, y) :: zs when x = y -> (n + 1, y) :: zs
| zs -> (1, x) :: zs
in
fold_right f l []
Which is the same as:
let encode l =
let f x z = match z with
| (n, y) :: zs when x = y -> (n + 1, y) :: zs
| zs -> (1, x) :: zs
in
fold_right f l []
Which is the same as:
let encode l =
fold_right (fun x z ->
match z with
| (n, y) :: zs when x = y -> (n + 1, y) :: zs
| zs -> (1, x) :: zs
) l []