tag:blogger.com,1999:blog-67360123748447557232024-03-14T00:21:51.203-07:00Dan Weston's Haskell CodeSome random code I've written. Everything is under Simplified BSD license, so help yourself!Zo Kwe Zohttp://www.blogger.com/profile/11009268051282300971noreply@blogger.comBlogger7125tag:blogger.com,1999:blog-6736012374844755723.post-44986220900253489272009-01-04T19:36:00.001-08:002009-01-04T19:41:01.361-08:00GridZipperHere is some code I wrote to implement an idea posed by someone on HaskellCafe.</p><br /><pre><br />-- |2-D infinite grid with O(1) lookup, modification, and incremental move<br />-- <br />-- Data is saved sparsely (wrapped in Maybe) with a rose tree zipper<br />-- where depth is manhattan distance from origin, and sibling index is order<br />-- CCW around a diamond centered at origin. Sparsity maximized by independent<br />-- angular offset for each radius, with only adjacent points stored.<br />--<br />-- Uses "Data.Tree.Zipper" which can be found on hackage at<br />-- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/rosezipper><br />-- <br />-- Data.Tree is indexed by Int. For unbounded grid, rewrite using Integer<br />--<br />-- Copyright (c) Dan Weston, 2008. All rights reserved.<br />--<br />-- License: Simplified BSD.<br /><br />module GridZipper (<br /> -- * Grid representation<br /> module Data.Tree,<br /> module Data.Tree.Zipper,<br /> GridLabel(..),<br /> Grid,<br /> GridZipper,<br /> newGrid,<br /> -- * Grid coordinates<br /> XY(..),<br /> RK(..),<br /> getRK,getXY,<br /> cartesianFromPolar,polarFromCartesian,<br /> -- * Grid values<br /> getValue,newValue,setValue,<br /> -- * Moving around the grid<br /> goToRK,goToXY,moveInXY,north,south,east,west,<br /> -- * Example usage<br /> assocList,sampleUsage<br /> ) where<br /><br /><br />import Data.Tree.Zipper(TreeLoc,getLabel,setLabel,modifyLabel,<br /> root,parent,left,right,firstChild,toTree,fromTree,<br /> insertRight,insertDownFirst)<br />import Data.Tree (Tree,flatten)<br />import Data.Maybe (maybe,isJust,fromJust)<br /><br />------------------------------------------------------------------------------<br />-- DATA TYPES<br />------------------------------------------------------------------------------<br /><br />-- |Cartesian grid coordinates<br />data XY = XY Int Int deriving (Eq,Show)<br /><br />-- |Polar grid coordinates<br />-- r = |x| + |y| (manhattan distance form origin)<br />-- k = index around diamond, starting at (+r,0)<br />data RK = RK Int Int deriving (Eq,Show)<br /><br />-- |Grid label<br />data GridLabel a = GridLabel RK (Maybe a) deriving (Eq,Show)<br /><br />-- |Grid represented as rose tree (radius = depth, angle = width)<br />type Grid a = Tree (GridLabel a)<br /><br />-- |Cursor is rose tree zipper (polar coords stored in label alongside value)<br />type GridZipper a = TreeLoc (GridLabel a)<br /><br /><br />------------------------------------------------------------------------------<br />-- COORDINATE CONVERSION<br />------------------------------------------------------------------------------<br /><br />-- |Gets cartesian coordinates from polar ones<br />cartesianFromPolar :: RK -> XY<br />cartesianFromPolar (RK 0 0) = XY 0 0<br />cartesianFromPolar (RK r k) = case q of<br /> 0 -> XY (r - s ) (s )<br /> 1 -> XY (negate s) (r - s )<br /> 2 -> XY (s - r ) (negate s)<br /> 3 -> XY (s ) (s - r )<br /> where (q,s) = k `divMod` r<br /><br />-- |Gets polar coordinates from cartesian ones<br />polarFromCartesian :: XY -> RK<br />polarFromCartesian (XY 0 0) = RK 0 0<br />polarFromCartesian (XY x y)<br /> | x > 0 && y >= 0 = RK r y<br /> | y > 0 && x <= 0 = RK r (r - x)<br /> | x < 0 && y <= 0 = RK r (2*r - y)<br /> | y < 0 && x >= 0 = RK r (3*r + x)<br /> where r = abs x + abs y<br /><br />------------------------------------------------------------------------------<br />-- COORDINATE ACCESS<br />------------------------------------------------------------------------------<br /><br />-- |Extracts polar coordinates from label<br />getRK :: GridLabel a -> RK<br />getRK (GridLabel rk _) = rk<br /><br />-- |Extracts cartesian coordinates from label<br />getXY :: GridLabel a -> XY<br />getXY = cartesianFromPolar . getRK<br /><br />------------------------------------------------------------------------------<br />-- VALUE ACCESS AND MODIFY<br />------------------------------------------------------------------------------<br /><br />-- |Extracts grid value, if any, from label<br />getValue :: GridLabel a -> Maybe a<br />getValue (GridLabel _ value) = value<br /><br />-- |Returns copy, replacing grid value<br />newValue :: Maybe a -> GridLabel a -> GridLabel a<br />newValue v (GridLabel rk _) = GridLabel rk v<br /><br />-- |Returns copy, replacing grid value<br />setValue :: Maybe a -> GridZipper a -> GridZipper a<br />setValue v = modifyLabel (newValue v)<br /><br />------------------------------------------------------------------------------<br />-- NODE CREATION<br />------------------------------------------------------------------------------<br /><br />-- |New empty grid<br />newGrid :: Grid a<br />newGrid = newNode (RK 0 0)<br /><br />------------------------------------------------------------------------------<br />-- MOVING THROUGH GRID<br />------------------------------------------------------------------------------<br /><br />-- |Move to new polar coords<br />goToRK :: RK -> GridZipper a -> GridZipper a<br />goToRK rk@(RK r k) z<br /> | r < 0 = error "goToRK called with r < 0"<br /> | r == 0 = root z<br /> | r == rCurr = moveAround rk . leftmostSibling $ z<br /> | r > rCurr = moveOut rCurr rk z<br /> | otherwise = moveIn rCurr rk z<br /> where RK rCurr _ = getRK . getLabel $ z<br /><br />-- Move to new cartesian coordinate<br />goToXY :: XY -> GridZipper a -> GridZipper a<br />goToXY = goToRK . polarFromCartesian<br /><br />-- |Move relatively in delta cartesian coordinates<br />moveInXY :: Int -> Int -> GridZipper a -> GridZipper a<br />moveInXY dx dy z = goToXY (XY (xOld + dx) (yOld + dy)) $ z<br /> where XY xOld yOld = getXY . getLabel $ z<br /><br />-- |Move up one step<br />north :: GridZipper a -> GridZipper a<br />north = moveInXY 0 1<br /><br />-- |Move down one step<br />south :: GridZipper a -> GridZipper a<br />south = moveInXY 0 (-1)<br /><br />-- |Move right one step<br />east :: GridZipper a -> GridZipper a<br />east = moveInXY 1 0<br /><br />-- |Move left one step<br />west :: GridZipper a -> GridZipper a<br />west = moveInXY (-1) 0<br /><br />-- |Display grid as association list: (xy,getValue)<br />assocList :: GridZipper a -> [(XY,a)]<br />assocList = map (\l -> (getXY $ l,<br /> fromJust . getValue $ l))<br /> . filter (isJust . getValue)<br /> . flatten<br /> . toTree<br /> . root<br /><br />-- |Example of walking grid from origin, setting values<br />-- <br />-- > sampleUsage = putStrLn . show . (assocList &&& id) . walkGrid . fromTree<br />-- > $ (newGrid :: Grid String)<br />-- > where f &&& g = \x -> (f x, g x)<br />-- > f >>> g = g . f<br />-- > walkGrid = east >>> setValue (Just "XY 1 0")<br />-- > >>> north >>> west >>> setValue (Just "XY 0 1")<br />-- > >>> south >>> setValue (Just "XY 0 0")<br />-- > >>> south >>> setValue (Just "XY 0 (-1)")<br />-- <br />sampleUsage :: IO ()<br />sampleUsage = putStrLn . show . (assocList &&& id) . walkGrid . fromTree<br /> $ (newGrid :: Grid String)<br /> where f &&& g = \x -> (f x, g x)<br /> f >>> g = g . f<br /> walkGrid = east >>> setValue (Just "XY 1 0")<br /> >>> north >>> west >>> setValue (Just "XY 0 1")<br /> >>> south >>> setValue (Just "XY 0 0")<br /> >>> south >>> setValue (Just "d(XY 0 (-1)")<br /><br />------------------------------------------------------------------------------<br />-- HELPER FUNCTIONS NOT EXPORTED<br />------------------------------------------------------------------------------<br /><br />-- |Returns a new node, intended for a given polar coordinate<br />-- Note that all grids are anchored at the origin. Only the origin node<br />-- functions as a valid standalone grid.<br />newNode :: RK -> Grid a<br />newNode rk = return (GridLabel rk Nothing)<br /><br />-- |Gets leftmost sibling of current node (which may be current one)<br />leftmostSibling :: GridZipper a -> GridZipper a<br />leftmostSibling z = maybe z leftmostSibling . left $ z<br /><br />-- |Gets rightmost sibling of current node (which may be current one)<br />rightmostSibling :: GridZipper a -> GridZipper a<br />rightmostSibling z = maybe z rightmostSibling . right $ z<br /><br />-- |Move inward to new polar coordinate<br />moveIn :: Int -> RK -> GridZipper a -> GridZipper a<br />moveIn rCurr rk@(RK r k) z<br /> | rCurr == r = moveAround rk . leftmostSibling $ z<br /> | otherwise = moveIn (rCurr - 1) rk . fromJust . parent $ z<br /><br />-- |Move outward to new polar coordinate<br />moveOut :: Int -> RK -> GridZipper a -> GridZipper a<br />moveOut rCurr rk@(RK r k) z<br /> | r == rCurr+1 = zChild<br /> | otherwise = moveOut (rCurr + 1) rk zChild<br /> where zChild = moveOutOne rk z<br /><br />-- |Move outward exactly one unit of radius to new polar coordinate<br />-- This special case allows us to check if there is no child there and,<br />-- if so, to pick the angular anchor<br />-- Note that r passed in must be exactly one more than that of current node<br />moveOutOne :: RK -> GridZipper a -> GridZipper a<br />moveOutOne rk@(RK r k) z<br /> = maybe (insertDownFirst (newNode rk) z) (moveAround rk) $ firstChild z<br /><br />-- |Move relatively in angle around origin (along diamond perimeter)<br />-- Note that r passed in must match that of current node<br />moveAround :: RK -> GridZipper a -> GridZipper a<br />moveAround rk@(RK r k) z<br /> | k == kCurr = z<br /> | otherwise = maybe (insertRight (newNode rk) z) (moveAround rk) $ right z<br /> where RK _ kCurr = getRK . getLabel $ z<br /></pre>Zo Kwe Zohttp://www.blogger.com/profile/11009268051282300971noreply@blogger.comtag:blogger.com,1999:blog-6736012374844755723.post-31432494925940881022007-07-24T13:57:00.000-07:002007-07-24T14:08:00.384-07:00Average of a List<p>A quick example of how to take the average of a list in one pass:</p><br /><code><br />listAvg :: (Fractional b) => [b] -> b<br />listAvg = uncurry (/) . foldl' (\(sum,cnt) x -> (sum + x, cnt + 1)) (0,0)<br /></code>Zo Kwe Zohttp://www.blogger.com/profile/11009268051282300971noreply@blogger.comtag:blogger.com,1999:blog-6736012374844755723.post-51942937060032062742007-07-15T00:44:00.000-07:002007-07-15T00:46:17.999-07:00Simple prime factorization code<code><br />primes :: [Integer]<br />primes = primes' (2:[3,5..])<br /> where primes' (x:xs) = x : primes' (filter (notDivisorOf x) xs)<br /> notDivisorOf d n = n `mod` d /= 0<br /><br />factors :: [Integer] -> Integer -> [Integer]<br />factors qs@(p:ps) n<br /> | n <= 1 = []<br /> | m == 0 = p : factors qs d<br /> | otherwise = factors ps n<br /> where (d,m) = n `divMod` p<br /><br />primeFactors :: Integer -> [Integer]<br />primeFactors = factors primes<br /></code>Zo Kwe Zohttp://www.blogger.com/profile/11009268051282300971noreply@blogger.comtag:blogger.com,1999:blog-6736012374844755723.post-46276612123954425212007-04-20T15:22:00.000-07:002007-04-20T15:32:49.348-07:00Relational Algebra<PRE><br />module RelationalAlgebra(innerJoin,transitiveClosure) where<br /><br />import Data.List(sort,nubBy)<br />import Control.Arrow((***))<br /><br />----------------------------------------------------------------------<br />-- RELATIONAL ALGEBRA<br /><br />ifKeyMatchesAddValue seekKey (findKey,value) =<br /> if seekKey === findKey then (:) value<br /> else id<br /><br />lookupAll seekKey = foldr (ifKeyMatchesAddValue seekKey) []<br />lookupAllIn keyValueDict = flip lookupAll keyValueDict<br /><br />-- PRE : abDict and bcDict are set-like<br />-- POST: Returned acDict is set-like<br />innerJoin :: (Ord a, Ord b, Ord c) => [(a, b)] -> [(b, c)] -> [(a, c)]<br />innerJoin abDict bcDict = concatMap innerJoinFor joinKeys<br /> where getKeys = map fst<br /> `andThen` removeDupsFromSorted<br /> joinKeys = getKeys abDict<br /> joinedValues = lookupAllIn abDict<br /> `andThen` concatMap (lookupAllIn bcDict)<br /> `andThen` sortAndRemoveDups<br /> innerJoinFor = dup -- key into (joinKey,seekKey)<br /> `andThen` (repeat {- joinKey -} ***<br /> joinedValues {- seekKey -})<br /> `andThen` uncurry zip -- (joinKey,joinedValues)<br /><br />-- PRE : Arg is set-like<br />-- POST: Returned is set-like, transitiveClosure is idempotent<br />transitiveClosure :: (Ord a) => [(a, a)] -> [(a, a)]<br />transitiveClosure aaDict<br /> | aaDict === aaDictNew = aaDictNew<br /> | otherwise = transitiveClosure aaDictNew<br /> where aaDictNew = mergeInSelfJoin aaDict<br /> mergeInSelfJoin d = d `merge` innerJoin d d<br /><br />----------------------------------------------------------------------<br />-- USING LISTS AS SETS<br /><br />-- DEF: A list is set-like if it is in strictly increasing order<br /><br />-- Why is this not in Prelude?<br />dup x = (x,x)<br /><br />-- I prefer reading function composition from left-to-right<br />andThen = flip (.)<br /><br />-- Uses < instead of == to preserve set-like structures<br />x === y = not (x < y || y < x)<br /><br />-- PRE : Arg is sorted<br />-- POST: Result is set-like<br />removeDupsFromSorted :: Ord a => [a] -> [a]<br />removeDupsFromSorted = nubBy (===)<br /><br />-- POST: Result is set-like<br />sortAndRemoveDups :: Ord a => [a] -> [a]<br />sortAndRemoveDups = sort<br /> `andThen` removeDupsFromSorted<br /><br />-- PRE : Args are set-like<br />-- POST: Result is set-like, the sorted union of args<br />merge as [] = as<br />merge [] bs = bs<br />merge aas@(a:as) bbs@(b:bs) | a < b = a : merge as bbs<br /> | b < a = b : merge aas bs<br /> | otherwise = a : merge as bs<br /></PRE>Zo Kwe Zohttp://www.blogger.com/profile/11009268051282300971noreply@blogger.comtag:blogger.com,1999:blog-6736012374844755723.post-8649751940659548752006-12-08T19:04:00.000-08:002006-12-08T19:12:06.721-08:00Haskell code for ifThenElseif/then/else can be so ugly. I prefer the C ternary operator (cond ? t : f)<br /><br />In Haskell, since functions are first class objects, this becomes especially powerful:<br /><br /><pre><br />module ArrowChoiceOps((?),(??),(???),(????)) where<br /><br />import Control.Arrow<br />import Data.Either<br /><br />infix 1 ?, ??, ???, ????<br /><br />(?) :: Bool -> a -> Either a a<br />(?) True = Left<br />(?) False = Right<br /><br />(??) :: Bool -> (a, b) -> Either a b<br />(??) True = Left . fst<br />(??) False = Right . snd<br /><br />(???) :: (a -> Bool) -> (Either a a -> d) -> a -> d<br />p ??? q = (p &&& arr id) >>> uncurry (?) >>> q<br /><br />(????) :: ((a, b) -> Bool) -> (Either a b -> d) -> (a, b) -> d<br />p ???? q = (p &&& arr id) >>> uncurry (??) >>> q<br /></pre><br /><br />No code is complete without a test harness:<br /><br /><pre><br />module Main where<br /><br />import ArrowChoiceOps<br />import Control.Monad<br />import Control.Arrow<br />import Data.Either<br />import Data.Maybe<br /><br /><br />-- |Famous general recursion problem, does this halt for all n?<br />recurse :: Int -> [Int]<br />recurse n = takeWhile (> 0) . iterate takeAStep $ n<br /> where takeAStep = (<= 1) ??? const 0<br /> ||| (even ??? (`div` 2)<br /> ||| (+1) . (*3))<br /><br />-- |Faking mplus if Maybe weren't a MonadPlus<br />mplusMaybe :: Maybe a -> Maybe a -> Maybe a<br />mplusMaybe = curry (isJust . fst ???? id ||| id)<br /><br />-- |Fake abs<br />abs' :: (Num a, Ord a) => a -> a<br />abs' = (< 0) ??? negate ||| id<br /><br />checks :: [Bool]<br />checks =<br /> [<br /> (True ? 3 ) == (Left 3),<br /> (False ? 4 ) == (Right 4),<br /> (True ?? (3,4)) == (Left 3),<br /> (False ?? (3,4)) == (Right 4),<br /> (even ??? (`div` 2) ||| (+1).(*3) $ 3 ) == ( 10),<br /> (even ??? (`div` 2) ||| (+1).(*3) $ 4 ) == ( 2),<br /> (uncurry (==) ???? (+1) ||| (*3) $ (3,3)) == ( 4),<br /> (uncurry (==) ???? (+1) ||| (*3) $ (3,4)) == ( 12),<br /> (uncurry (==) ???? (+1) +++ (*3) $ (3,3)) == (Left 4),<br /> (uncurry (==) ???? (+1) +++ (*3) $ (3,4)) == (Right 12),<br /> (Nothing `mplusMaybe` Nothing :: Maybe ()) ==<br /> (Nothing `mplus` Nothing :: Maybe ()),<br /> (Just 3 `mplusMaybe` Nothing) ==<br /> (Just 3 `mplus` Nothing),<br /> (Nothing `mplusMaybe` Just 4) ==<br /> (Nothing `mplus` Just 4),<br /> (Just 3 `mplusMaybe` Just 4) ==<br /> (Just 3 `mplus` Just 4),<br /> (map recurse [-5..5]) == [[],[],[],[],[],[],[1],[2,1],<br /> [3,10,5,16,8,4,2,1],[4,2,1],[5,16,8,4,2,1]],<br /> (map abs' [-5..5]) == (map abs [-5..5])<br /> ]<br /><br />main :: IO ()<br />main = print (and checks)<br /></pre>Zo Kwe Zohttp://www.blogger.com/profile/11009268051282300971noreply@blogger.comtag:blogger.com,1999:blog-6736012374844755723.post-613177266525734702006-12-08T18:52:00.000-08:002006-12-11T12:03:52.882-08:00Haskell code to list prime numbers<pre><br />-- Just calculate the infinite list of primes (lazily),<br />-- then trip the range to fit<br />primeGenerator [start,end] = takeWhile (<= end)<br /> . dropWhile (< start)<br /> $ primes<br /><br />-- Pointed notation with list comprehensions<br />primes = (2 : [x | x <- [3,5..], isPrime x])<br /><br />-- Efficient test presupposes the existence of primes<br />-- This works because to determine whether p is prime you only need<br />-- to know the primes strictly less than p (except for 2 of course!)<br />isPrime x = null divisors<br /> where divisors = [y | y <- onlyUpToSqrtX primes, x `mod` y == 0]<br /> onlyUpToSqrtX = fst . span (<= sqrtX)<br /> sqrtX = floor (sqrt (fromIntegral x))<br /><br />-- A point-free notation, as an alternative<br />primes' = (2 : filter isPrime [3,5..]) -- indivisible n > 1<br /> where isPrime = all (/= 0) -- i.e. all are nonzero of:<br /> . remOf -- remainders of odd ints<br /> -- where remOf n is when you<br /> remOf n = map (mod n) -- divide into n a list of<br /> . flip take primes' -- primes, but only<br /> . length -- as many as<br /> . takeWhile (<= n) -- are less than n, that is<br /> . map (^ 2) -- the square of each of the<br /> $ primes' -- primes<br /><br /></pre><br /><br /><SMALL>NOTE: <EM>all (/= 0)</EM> was provided by <A href="mailto:bulat.ziganshin@gmail.com">Bulat Ziganshin</A> as an improvement on my orignal <EM>and . map (/=0)</EM>.</SMALL>Zo Kwe Zohttp://www.blogger.com/profile/11009268051282300971noreply@blogger.comtag:blogger.com,1999:blog-6736012374844755723.post-79718156876386173012006-12-08T18:45:00.000-08:002006-12-08T18:51:40.846-08:00Favorite quotes about C++Proposers of new [C++] features should be required to donate a kidney. That would (as Jim Waldo pointed out) make people think hard before proposing [one], and even people without any sense would propose at most two extensions.<br /><br /><span style="font-style: italic;"> -- Bjarne Stroustrup, creator of C++ </span><br /><br /><br />If you think C++ is not overly complicated, just what is a protected abstract virtual base pure virtual private destructor, and when was the last time you needed one?<br /><br /> <span style="font-style: italic;"> -- Tom Cargil, C++ Journal </span>Zo Kwe Zohttp://www.blogger.com/profile/11009268051282300971noreply@blogger.com