I'm trying to translate this piece of code in Haskell that describes List anamorphism but can't quite get it to work.
The final three lines are supposed to generate a function count which given an int will produce an int list [n, n-1, ..., 1]
Haskell code:
data Either a b = Left a | Right b
type List_coalg u x = u -> Either () (x, u)
list ana :: List_coalg u x -> u -> [x]
list_ana a = ana where
ana u = case a u of
Left _ -> []
Right (x, l) -> x : ana l
count = list_ana destruct_count
destruct_count 0 = Left ()
destruct_count n = Right (n, n-1)
What I have so far:
type ('a, 'b) List_coalg = 'a -> (unit, 'a*'b) Either
fun list_ana (f : ('a, 'b) List_coalg) : 'a -> 'b list =
let
fun ana a : 'b list =
case f a of
Left () => []
| Right (x, l) => x :: ana l
in
ana
end
fun destruct_count 0 = Left ()
| destruct_count n = Right (n, n-1)
val count = list_ana destruct_count
I get the following error:
catamorphism.sml:22.7-24.35 Error: case object and rules do not agree [UBOUND match]
rule domain: (unit,'b * 'a) Either
object: (unit,'a * 'b) Either
in expression:
(case (f a)
of Left () => nil
| Right (x,l) => x :: ana l)
Not sure how to fix this as I am not super proficient in SML.
As you mentioned in the comments, the type parameters got mixed up. With a bit of renaming for comparison:
type List_coalg a b = a -> Either () (b, a) -- (b, a)
type ('a, 'b) List_coalg = 'a -> (unit, 'a*'b) Either (* ('a * 'b) *)
which leads to a mismatch after pattern-matching on the pair:
Right (x, l) -> x : ana l
-- x :: b
-- l :: a
Right (x, l) => x :: ana l
(* x : 'a *)
(* l : 'b *)
Related
I started reading Chapter 6 of "Type-driven development with Idris" and attempted to write a smart constructor for a tupled vector.
TupleVect : Nat -> Type -> Type
TupleVect Z _ = ()
TupleVect (S k) a = (a, TupleVect k a)
someValue : TupleVect 4 Nat
someValue = (1,2,3,4,())
TupleVectConstructorType : Nat -> Type -> Type
TupleVectConstructorType n typ = helper n
where
helper : Nat -> Type
helper Z = TupleVect n typ
helper (S k) = typ -> helper k
tupleVect : (n : Nat) -> (a : Type) -> TupleVectConstructorType n a
tupleVect Z a = ()
tupleVect (S Z) a = \val => (val, ())
tupleVect (S (S Z)) a = \val2 => \val1 => (val2, val1, ())
-- ??? how to create tupleVect (S k) a
How to create a constructor for an arbitrary k?
Basically #Matthias Berndt's idea. Counting down the arrows to be added, while making the final tuple longer. For this we need to access the more permissive helper from TupleVectType.
TupleVectType' : Nat -> Nat -> Type -> Type
TupleVectType' Z n a = TupleVect n a
TupleVectType' (S k) n a = a -> TupleVectType' k (S n) a
TupleVectType : Nat -> Type -> Type
TupleVectType n = TupleVectType' n Z
tupleVect : (n : Nat) -> (a : Type) -> TupleVectType n a
tupleVect n a = helper n Z a ()
where
helper : (k, n : Nat) -> (a : Type) -> (acc : TupleVect n a)
-> TupleVectType' k n a
helper Z n a acc = acc
helper (S k) n a acc = \x => helper k (S n) a (x, acc)
someValue2 : TupleVect 4 Nat
someValue2 = (tupleVect 4 Nat) 4 3 2 1
Though note that this will result in \v2 => \v1 => (v1, v2, ()) and not \v2 => \v1 => (v2, v1, ()) as the former fits the recursive definition of TupleVect (S k) a = (a, TupleVect k a) better.
I know almost nothing about Idris except that it's a dependently-typed, Haskell-like language. But I find this problem intriguing, so I gave it a shot.
Clearly you need a recursive solution here. My idea is to use an additional parameter f which accumulates the val1..val_n parameters that the function has eaten so far. When the base case is reached, f is returned.
tupleVectHelper Z a f = f
tupleVectHelper (S n) a f = \val => tupleVectHelper n a (val, f)
tupleVect n a = tupleVectHelper n a ()
I have no idea if this works, and I haven't yet figured out how to write the type of tupleVectHelper, but I've tried doing the substitutions manually for n = 3 and it does seem to work out on paper, though the resulting tuple is backwards. But I think that shouldn't be too hard to fix.
Hope this helps!
I ran into the following error in Haskell:
"Type signatures are only allowed in patterns with ScopedTypeVariables"
How should I re-use the defined variables. Thanks in advance
sum :: (Double -> Double) -> (Double -> Double) -> Int ->
(Double -> Double)
sum f g n = (\x -> helper f g n x)
where
helper :: (Double -> Double) -> (Double -> Double) -> Int -> Double ->
Double
|n == 0 = 0
|mod n 2 == 1 = f(x) + helper f g n-1 f(x)
|otherwise = g(x) + helper f g n-1 g(x)
This actually looks more like a syntactical error: you never defined a function body for helper, indeed you defined the signature of helper, followed by guards (the | ... part), but you should again state helper f g n x = ....
Furthermore I don't think it is useful to define helper here with a variable for f, an g, since these remain fixed throughout the recursion.
You can probably define the function as:
sumfg :: (Double -> Double) -> (Double -> Double) -> Int -> Double -> Double
sumfg f g = helperf
where helperf 0 _ = 0
helperf i x = let fx = f x in fx + helperg (i-1) fx
helperg 0 _ = 0
helperg i x = let gx = g x in gx + helperf (i-1) gx
We here defined two "helper" functions helperf and helperg, helperf will sum up f x with helperg (i-1) (f x), and helperg does the same, except that we use g instead of f. We here thus use mutual recursion to solve the problem.
We can however solve this problem more elegantly, by making use of scanl :: (b -> a -> b) -> b -> [a] -> [b], take :: Int -> [a] and sum :: Num a => [a] -> a:
sumfg :: Num a => (a -> a) -> (a -> a) -> Int -> a -> a
sumfg f g n x = sum (take n (scanl (flip ($)) (f x) (cycle [g, f])))
Here we thus make an infinite list of g and f, like [g, f, g, f, g, f, ...] with cycle [f, g]. We then use scanl (flip ($)) to each time apply the accumulator to one of the functions, and yield that element. We take the first n items of that list with take n, and finally we use sum to sum up these values.
For example:
Prelude> sumfg (2+) (3*) 5 1
91
Since (2+1) + (3*(2+1)) + (2+(3*(2+1))) + (3*(2+(3*(2+1)))) + (2+(3*(2+(3*(2+1))))) is 91.
We also generalized the signature: we can now work with any numerical type a, with the two functions f and g of type f, g :: a -> a.
One of the assignments I am working on leading up to exams had me create
data Exp = T | F | And Exp Exp | Or Exp Exp | Not Exp deriving (Eq, Show, Ord, Read)
Then it asked to make
folde :: a -> a -> (a -> a -> a) -> (a -> a -> a) -> (a -> a) -> Exp -> a
This is what I came up with
folde :: a -> a -> (a -> a -> a) -> (a -> a -> a) -> (a -> a) -> Exp -> a
folde t f a o n T = t
folde t f a o n F = f
folde t f a o n (And x y) = a (folde t f a o n x) (folde t f a o n y)
folde t f a o n (Or x y) = o (folde t f a o n x) (folde t f a o n y)
folde t f a o n (Not x) = n (folde t f a o n x)
The assignment asks for evb, evi and evh.
They are all supposed to work with one single call to folde using correct parameters.
Evb evaluates boolean expressions.
evb :: Exp -> Bool
evb = folde True False (&&) (||) not
Evi evaluates to an integer, treating T as Int 1, F as Int 5, And as +, Or as * and Not as negate.
evi :: Exp -> Int
evi = folde 1 5 (+) (*) negate
So far so good, it all works. I'll be happy for any feedback on this as well.
However, I can't seem to understand how to solve the evh.
evh is supposed to calculate the heigh of the tree.
It should be evh :: Exp -> Int
The assignment says it should treat T and F as height 1.
It goes on that Not x should evaluate to height x + 1. And and Or has the height of its tallest subtree + 1.
I can't seem to figure out what I should pass on to my folde function
The assignment says it should treat T and F as height 1. It goes on that Not x should evaluate to height x + 1. And and Or has the height of its tallest subtree + 1.
You can write this pretty directly with explicit recursion:
height T = 1
height F = 1
height (Not x) = height x + 1
height (And x y) = max (height x) (height y) + 1
height (Or x y) = max (height x) (height y) + 1
Now, how do you write this with folde? The key thing about recursive folding is that folde gives each of your functions the result of folding all the subtrees. When you folde on And l r, it folds both subtrees first, and then passes those results into the argument to folde. So, instead of you manually calling height x, folde is going to calculate that for you and pass it as an argument, so your own work ends up something like \x y -> max x y + 1. Essentially, split height into 5 definitions, one per constructor, and instead of destructuring and recursing down subtrees, take the heights of the subtrees as arguments:
heightT = 1 -- height T = 1
heightF = 1 -- height F = 1
heightN x = x + 1 -- height (Not x) = height x + 1
heightA l r = max l r + 1 -- height (And l r) = max (height l) (height r) + 1
heightO l r = max l r + 1 -- height (Or l r) = max (height l) (height r) + 1
Feed them to folde, and simplify
height = folde 1 1 -- T F
ao -- And
ao -- Or
(+1) -- Not
where ao x y = max x y + 1
And now for something new! Take this definition:
data ExpF a = T | F | Not a | And a a | Or a a
deriving (Functor, Foldable, Traversable)
This looks like your Exp, except instead of recursion it's got a type parameter and a bunch of holes for values of that type. Now, take a look at the types of expressions under ExpF:
T :: forall a. ExpF a
Not F :: forall a. ExpF (ExpF a)
And F (Not T) :: forall a. ExpF (ExpF (ExpF a))
If you set a = ExpF (ExpF (ExpF (ExpF (ExpF ...)))) (on to infinity) in each of the above, you find that they can all be made to have the same type:
T :: ExpF (ExpF (ExpF ...))
Not F :: ExpF (ExpF (ExpF ...))
And F (Not T) :: ExpF (ExpF (ExpF ...))
Infinity is fun! We can encode this infinitely recursive type with Fix
newtype Fix f = Fix { unFix :: f (Fix f) }
-- Compare
-- Type level: Fix f = f (Fix f)
-- Value level: fix f = f (fix f)
-- Fix ExpF = ExpF (ExpF (ExpF ...))
-- fix (1:) = 1:( 1:( 1: ...))
-- Recover original Exp
type Exp = Fix ExpF
-- Sprinkle Fix everywhere to make it work
Fix T :: Exp
Fix $ And (Fix T) (Fix $ Not $ Fix F) :: Exp
-- can also use pattern synonyms
pattern T' = Fix T
pattern F' = Fix F
pattern Not' t = Fix (Not t)
pattern And' l r = Fix (And l r)
pattern Or' l r = Fix (Or l r)
T' :: Exp
And' T' (Not' F') :: Exp
And now here's the nice part: one definition of fold to rule them all:
fold :: Functor f => (f a -> a) -> Fix f -> a
fold alg (Fix ffix) = alg $ fold alg <$> ffix
-- ffix :: f (Fix f)
-- fold alg :: Fix f -> a
-- fold alg <$> ffix :: f a
-- ^ Hey, remember when I said folds fold the subtrees first?
-- Here you can see it very literally
Here's a monomorphic height
height = fold $ \case -- LambdaCase extension: \case ... ~=> \fresh -> case fresh of ...
T -> 1
F -> 1
Not x -> x + 1
And x y -> max x y + 1
Or x y -> max x y + 1
And now a very polymorphic height (in your case it's off by one; oh well).
height = fold $ option 0 (+1) . fmap getMax . foldMap (Option . Just . Max)
height $ Fix T -- 0
height $ Fix $ And (Fix T) (Fix $ Not $ Fix F) -- 2
See the recursion-schemes package to learn these dark arts. It also makes this work for base types like [] with a type family, and removes the need to Fix everything with said trickery + some TH.
I am trying to define a function that accepts a point (x,y) as input, and returns an infinite list corresponding to recursively calling
P = (u^2 − v^2 + x, 2uv + y)
The initial values of u and v are both 0.
The first call would be
P = (0^2 - 0^2 + 1, 2(0)(0) + 2) = (1,2)
Then that resulting tuple (1,2) would be the next values for u and v, so then it would be
P = (1^2 - 2^2 + 1, 2(1)(2) + 2) = (-2,6)
and so on.
I'm trying to figure out how to code this in Haskell. This is what I have so far:
o :: Num a =>(a,a) -> [(a,a)]
o (x,y) = [(a,b)| (a,b)<- [p(x,y)(x,y)]]
where p(x,y)(u,v) = ((u^2)-(v^2)+x,(2*u*v)+y)
I'm really not sure how to make this work. Any help would be appreciated!
Let's first ignore the exact question you have, and focus on getting the loop working. What you want, essentially, is to have something that takes some initial value iv (namely, (0, 0) for (u, v)), and returns the list
f iv : f (f iv) : f (f (f iv)) : f (f (f (f iv))) : ...
for some function f (constructed from your p and (x, y)). Moreover, you want the result to reuse the previously computed elements of the list. If I would write a function myself that does this, it might looke like this (but maybe with some different names):
looper :: (a -> a) -> a -> [a]
looper f iv = one_result : more_results
where
one_result = f iv
more_results = looper f one_result
But, of course, I would first look if a function with that type exists. It does: it's called Data.List.iterate. The only thing it does wrong is the first element of the list will be iv, but that can be easily fixed by using tail (which is fine here: as long as your iteration function terminates, iterate will always generate an infinite list).
Let's now get back to your case. We established that it'll generally look like this:
o :: Num a => (a, a) -> [(a, a)]
o (x, y) = tail (iterate f iv)
where
f (u, v) = undefined
iv = undefined
As you indicated, the initial value of (u, v) is (0, 0), so that's what our definition of iv will be. f now has to call p with the (x, y) from o's argument and the (u, v) for that iteration:
o :: Num a => (a, a) -> [(a, a)]
o (x, y) = tail (iterate f iv)
where
f (u, v) = p (x, y) (u, v)
iv = (0, 0)
p = undefined
It's as simple as that: the (x, y) from o's definition is actually in scope in the where-clause. You could even decide to merge f and p, and end up with
o :: Num a => (a, a) -> [(a, a)]
o (x, y) = tail (iterate p iv)
where
iv = (0, 0)
p (u, v) = (u^2 - v^2 + x, 2 * u * v + y)
Also, may I suggest that you use Data.Complex for your application? This makes the constraints on a a bit stricter (you need RealFloat a, because of Num.signum), but in my opinion, it makes your code much easier to read:
import Data.Complex
import Data.List (iterate)
{- ... -}
o :: Num (Complex a) => Complex a -> [Complex a]
o c = tail (iterate p iv)
where
iv = 0 -- or "0 :+ 0", if you want to be explicit
p z = z^2 + c
You want:
To construct a list [(u, v)] with the head of this list equal (0, 0)
And then map this list with the function \(u, v) -> (u^2 - v^2 + x, 2 * u * v + y), appending results of this function to the list.
We can write this function as described:
func :: (Num t) => (t, t) -> [(t, t)]
func (x, y) = (0, 0) : map functionP (func (x, y))
where functionP (u, v) = (u^2 - v^2 + x, 2 * u * v + y)
GHCi > take 5 $ func (1, 2)
> [(0,0),(1,2),(-2,6),(-31,-22),(478,1366)]
I have a recursive function f that takes two parameters x and y. The function is uniquely determined by the first parameter; the second one merely makes things easier.
I now want to memoise that function w.r.t. it's first parameter while ignoring the second one. (I.e. f is evaluated at most one for every value of x)
What is the easiest way to do that? At the moment, I simply define an array containing all values recursively, but that is a somewhat ad-hoc solution. I would prefer some kind of memoisation combinator that I can just throw at my function.
EDIT: to clarify, the function f takes a pair of integers and a list. The first integer is some parameter value, the second one denotes the index of an element in some global list xs to consume.
To avoid indexing the list, I pass the partially consumed list to f as well, but obviously, the invariant is that if the first parameter is (m, n), the second one will always be drop n xs, so the result is uniquely determined by the first parameter.
Just using a memoisation combinator on the partially applied function will not work, since that will leave an unevaluated thunk \xs -> … lying around. I could probably wrap the two parameters in a datatype whose Eq instance ignores the second value (and similarly for other instances), but that seems like a very ad-hoc solution. Is there not an easier way?
EDIT2: The concrete function I want to memoise:
g :: [(Int, Int)] -> Int -> Int
g xs n = f 0 n
where f :: Int -> Int -> Int
f _ 0 = 0
f m n
| m == length xs = 0
| w > n = f (m + 1) n
| otherwise = maximum [f (m + 1) n, v + f (m + 1) (n - w)]
where (w, v) = xs !! m
To avoid the expensive indexing operation, I instead pass the partially-consumed list to f as well:
g' :: [(Int, Int)] -> Int -> Int
g' xs n = f xs 0 n
where f :: [(Int, Int)] -> Int -> Int -> Int
f [] _ _ = 0
f _ _ 0 = 0
f ((w,v) : xs) m n
| w > n = f xs (m + 1) n
| otherwise = maximum [f xs (m + 1) n, v + f xs (m + 1) (n - w)]
Memoisation of f w.r.t. the list parameter is, of course, unnecessary, since the list does not (morally) influence the result. I would therefore like the memoisation to simply ignore the list parameter.
Your function is unnecessarily complicated. You don't need the index m at all:
foo :: [(Int, Int)] -> Int -> Int
foo [] _ = 0
foo _ 0 = 0
foo ((w,v):xs) n
| w > n = foo xs n
| otherwise = foo xs n `max` foo xs (n - w) + v
Now if you want to memoize foo then both the arguments must be considered (as it should be).
We'll use the monadic memoization mixin method to memoize foo:
First, we create an uncurried version of foo (because we want to memoize both arguments):
foo' :: ([(Int, Int)], Int) -> Int
foo' ([], _) = 0
foo' (_, 0) = 0
foo' ((w,v):xs, n)
| w > n = foo' (xs, n)
| otherwise = foo' (xs, n) `max` foo' (xs, n - w) + v
Next, we monadify the function foo' (because we want to thread a memo table in the function):
foo' :: Monad m => ([(Int, Int)], Int) -> m Int
foo' ([], _) = return 0
foo' (_, 0) = return 0
foo' ((w,v):xs, n)
| w > n = foo' (xs, n)
| otherwise = do
a <- foo' (xs, n)
b <- foo' (xs, n - w)
return (a `max` b + v)
Then, we open the self-reference in foo' (because we want to call the memoized function):
type Endo a = a -> a
foo' :: Monad m => Endo (([(Int, Int)], Int) -> Int)
foo' _ ([], _) = return 0
foo' _ (_, 0) = return 0
foo' self ((w,v):xs, n)
| w > n = foo' (xs, n)
| otherwise = do
a <- self (xs, n)
b <- self (xs, n - w)
return (a `max` b + v)
We'll use the following memoization mixin to memoize our function foo':
type Dict a b m = (a -> m (Maybe b), a -> b -> m ())
memo :: Monad m => Dict a b m -> Endo (a -> m b)
memo (check, store) super a = do
b <- check a
case b of
Just b -> return b
Nothing -> do
b <- super a
store a b
return b
Our dictionary (memo table) will use the State monad and a Map data structure:
import Prelude hiding (lookup)
import Control.Monad.State
import Data.Map.Strict
mapDict :: Ord a => Dict a b (State (Map a b))
mapDict = (check, store) where
check a = gets (lookup a)
store a b = modify (insert a b)
Finally, we combine everything to create a memoized function memoFoo:
import Data.Function (fix)
type MapMemoized a b = a -> State (Map a b) b
memoFoo :: MapMemoized ([(Int, Int)], Int) Int
memoFoo = fix (memo mapDict . foo')
We can recover the original function foo as follows:
foo :: [(Int, Int)] -> Int -> Int
foo xs n = evalState (memoFoo (xs, n)) empty
Hope that helps.