Initial Haskell stuff
authorMichael Welch <michaelgwelch@gmail.com>
Sat, 10 Mar 2012 23:33:26 +0000 (17:33 -0600)
committerMichael Welch <michaelgwelch@gmail.com>
Sat, 10 Mar 2012 23:33:26 +0000 (17:33 -0600)
groups/FloatAddition.hs [new file with mode: 0644]
groups/NonZeroFloatMultiplication.hs [new file with mode: 0644]
groups/group.hs [new file with mode: 0644]
zipper/ziplist.hs [new file with mode: 0644]
zipper/ziptree.hs [new file with mode: 0644]

diff --git a/groups/FloatAddition.hs b/groups/FloatAddition.hs
new file mode 100644 (file)
index 0000000..218c254
--- /dev/null
@@ -0,0 +1,8 @@
+module FloatAddition where
+
+import Group
+
+instance Group Float where
+    identity = 0
+    operation = (+)
+    inverse = (0-)
diff --git a/groups/NonZeroFloatMultiplication.hs b/groups/NonZeroFloatMultiplication.hs
new file mode 100644 (file)
index 0000000..bdee11c
--- /dev/null
@@ -0,0 +1,9 @@
+module NonZeroFloatMult where
+
+import Group
+
+instance Group Float where
+    identity = 1.0
+    operation = (*)
+    inverse x | x == 0 = error "Zero has no inverse with respect to *"
+              | otherwise = (1/x)
diff --git a/groups/group.hs b/groups/group.hs
new file mode 100644 (file)
index 0000000..de130ca
--- /dev/null
@@ -0,0 +1,49 @@
+module Group where
+
+
+newtype Natural = Natural Int deriving (Eq, Show)
+
+toNat :: Int -> Natural
+toNat x | x < 0 = error "Naturals cannot be negative"
+        | otherwise = Natural x
+
+instance Num Natural where
+    x + y = toNat (fromNat x + fromNat y)
+    x - y = toNat (fromNat x - fromNat y)
+    x * y = toNat (fromNat x * fromNat y)
+    fromInteger = toNat . fromInteger
+    abs = id
+    signum = id
+
+fromNat :: Natural -> Int
+fromNat (Natural x) = x
+
+
+data NaturalAddition = NA Natural deriving (Eq, Show)
+
+
+class Eq a => Group a where
+    identity :: a
+    operation :: a -> a -> a
+    inverse :: a -> a
+
+    
+instance Group NaturalAddition where
+    identity = NA 0
+    operation (NA x) (NA y) = NA (x+y)
+    inverse (NA x) = NA (0-x)
+    
+assertCancellation :: Group a => a -> a -> a -> ()
+assertCancellation a b c | (b==c) && (operation a b) == (operation a c) = ()
+                         | (b==c) = error "Expected b equal to c" 
+                         | otherwise = error "Cancellation fails"
+
+assertIdentityCommutative :: Group a => a -> ()
+assertIdentityCommutative x | (operation identity x) == (operation x identity)
+                               && (operation identity x) == x  = ()
+                            | otherwise = error "This didn't work"
+
+assertIdentityInverse :: Group a => a -> ()
+assertIdentityInverse x | (operation x (inverse x)) == (operation (inverse x) x)
+                           && (operation x (inverse x) == identity) = ()
+                        | otherwise = error "Wrong"
diff --git a/zipper/ziplist.hs b/zipper/ziplist.hs
new file mode 100644 (file)
index 0000000..012df46
--- /dev/null
@@ -0,0 +1,7 @@
+
+-- single linked list
+data List a = Nil | Node a (List a)
+
+-- A location has a value and a pointer next,
+-- and a pointer previous.
+data Loc a = Loc a (List a) (List a)
diff --git a/zipper/ziptree.hs b/zipper/ziptree.hs
new file mode 100644 (file)
index 0000000..35b2a4a
--- /dev/null
@@ -0,0 +1,59 @@
+
+import Prelude hiding (Right, Left)
+import System.Random
+
+data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq)
+
+data Loc a = Loc (Tree a) (Context a) deriving (Show, Eq)
+
+data Context a = Top
+               | Left a (Tree a) (Context a)
+               | Right a (Tree a) (Context a) deriving (Show, Eq)
+
+data Ord a => Zipper a = Zip (Loc a) deriving (Show, Eq)
+
+zipper :: Ord a => Zipper a
+zipper = Zip (Loc Nil Top)
+
+moveUp :: Loc a -> Loc a
+moveUp (Loc _ Top) = error "Already at top of tree"
+moveUp (Loc lt (Right e rt p)) = Loc (Node e lt rt) p
+moveUp (Loc rt (Left e lt p)) = Loc (Node e lt rt) p
+
+moveLeft :: Loc a -> Loc a
+moveLeft (Loc Nil _) = error "No node to the left"
+moveLeft (Loc (Node e lt rt) c) = Loc lt (Right e rt c)
+
+moveRight :: Loc a -> Loc a
+moveRight (Loc Nil _) = error "No node to the right"
+moveRight (Loc (Node e lt rt) c) = Loc rt (Left e lt c)
+
+
+-- Adds a value of a to the tree given
+-- a location. It assumes that the given node
+-- is the root
+add :: Ord a => Tree a -> a -> Tree a
+add Nil e = Node e Nil Nil
+add (Node e' lt rt) e | e < e' = Node e' (add lt e) rt
+                      | e > e' = Node e' lt (add rt e)
+                      | otherwise = Node e' lt rt
+
+
+count :: Tree a -> Integer
+count Nil = 0
+count (Node _ lt rt) = 1 + count lt + count rt
+
+height :: Tree a -> Integer
+height Nil = 0;
+height (Node _ lt rt) = 1 + max (height lt) (height rt)
+
+
+randomInts :: Int -> IO [Int]
+randomInts n = do
+                 g <- newStdGen
+                 return $ take n $ randomRs (0,1000) g
+
+randomTree :: IO (Tree Int)
+randomTree = do 
+                 is <- randomInts 100
+                 return $ foldl (\t -> \v -> add t v) Nil is