Finite function module

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
-- A module which allows "finite functions" to be enumerated, compared, printed, etc.
-- From "Tips for Teaching Types and Functions" by Fritz Ruehr, FDPE '08
-- See <http://dl.acm.org/citation.cfm?id=1411272>
-- 3 sample test cases at the bottom of the file
-- (works in Hugs, needs some mods for recent GHC ... but would benefit from GHC's new "lambdacase")

module FinFun where

instance (Bounded a, Bounded b) => Bounded (a,b) where
  minBound = (minBound, minBound)
  maxBound = (maxBound, maxBound)

instance (Enum a, Bounded a, Enum b, Bounded b) => Enum (a,b) where
  toEnum k = (l,r)
             where (i,j) = divMod k (size r) 
                   (l,r) = (toEnum i, toEnum j)

  fromEnum (a,b) = sumProd (size b) (fromEnum a) (fromEnum b)

instance (Enum a, Bounded a, Enum b, Bounded b) => Bounded (a -> b) where
  minBound = toEnum 0 
  maxBound a = b
               where b = toEnum (size b - 1)

instance (Enum a, Bounded a, Enum b, Bounded b) => Enum (a -> b) where
  toEnum k x = y
               where y = toEnum (digits !! fromEnum x)
                     digits = unbaser (size y) k ++ repeat 0
  fromEnum f = baser b $ map (fromEnum . f) $ full
               where b = size (f minBound)

instance (Enum a, Bounded a, Eq b) => Eq (a -> b) where
  (==) f g = and [ f x == g x | x<-full ]

instance (Enum a, Bounded a, Enum b, Bounded b, Eq b) => Ord (a -> b) where 
  compare f g = compare (fromEnum f) (fromEnum g)

instance (Enum a, Bounded a, Show a, Show b) => Show (a -> b) where
  show f = (prefix . drop 2 . foldr1 (.) clauses) ")"
           where prefix = showString "(\\x -> case x of "
                 clauses = [ fmt x (f x) | x<-full ]
                 fmt x y = ("; "++) . shows x . (" -> "++) . shows y

-- Int version, not safe for large-sized types
size (x::a) = 1 + fromEnum (maxBound :: a) - fromEnum (minBound :: a)

full :: (Enum a, Bounded a) => [a]
full = [ minBound .. maxBound ]

-- positional notation utilities

sumProd b x y = b * x + y
swap (x,y) = (y,x)

baser   b = foldr         (flip   ( sumProd b)) 0
unbaser b = unfoldr (==0) (swap . (`divMod` b))

unfoldr p f x = if p x then [] else a : (unfoldr p f y)
                where (a,y) = f x


-------------
-- Sample test cases:


-- basic Boolean operator example
test0 = (&&) == (||)

-- simple deMorgan's law example
test1 = (&&) == (\x y -> not (not x || not y))

-- a higher-order example using deMorgan's law
test2 = (\q a -> not a || not (q a)) == flip (\b p -> not (p b && b))


----------- end of file -----------
30:26: Warning: Redundant $
Found:
map (fromEnum . f) $ full
Why not:
map (fromEnum . f) full
59:37: Warning: Redundant bracket
Found:
a : (unfoldr p f y)
Why not:
a : unfoldr p f y

Finite function module (annotation)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
---------------------------------------
-- A module which allows "finite functions" to be enumerated, compared, printed, etc.
-- From "Tips for Teaching Types and Functions" by Fritz Ruehr, FDPE '08
-- See <http://dl.acm.org/citation.cfm?id=1411272>
--
-- 4 sample test cases at the bottom of the file
-- (would benefit from GHC's new "lambdacase" syntax in 7.6.1)
---------------------------------------

{-# LANGUAGE ScopedTypeVariables #-}

module FinFun where

-- this instance hidden for compatibility with recent GHCs
-- (it is unnecessary in Hugs for, e.g., function comparison below)
{-
instance (Bounded a, Bounded b) => Bounded (a,b) where
  minBound = (minBound, minBound)
  maxBound = (maxBound, maxBound)
-}

instance (Enum a, Bounded a, Enum b, Bounded b) => Enum (a,b) where
  toEnum k = (l,r)
             where (i,j) = divMod k (size r) 
                   (l,r) = (toEnum i, toEnum j)

  fromEnum (a,b) = sumProd (size b) (fromEnum a) (fromEnum b)

instance (Enum a, Bounded a, Enum b, Bounded b) => Bounded (a -> b) where
  minBound = toEnum 0 
  maxBound a = b
               where b = toEnum (size b - 1)

instance (Enum a, Bounded a, Enum b, Bounded b) => Enum (a -> b) where
  toEnum k x = y
               where y = toEnum (digits !! fromEnum x)
                     digits = unbaser (size y) k ++ repeat 0

  fromEnum f = baser b $ map (fromEnum . f) $ full
               where b = size (f minBound)

instance (Enum a, Bounded a, Eq b) => Eq (a -> b) where
  (==) f g = and [ f x == g x | x<-full ]

instance (Enum a, Bounded a, Enum b, Bounded b, Eq b) => Ord (a -> b) where 
  compare f g = compare (fromEnum f) (fromEnum g)

instance (Enum a, Bounded a, Show a, Show b) => Show (a -> b) where
  show f = (prefix . drop 2 . foldr1 (.) clauses) ")"
           where prefix = showString "(\\x -> case x of "
                 clauses = [ fmt x (f x) | x<-full ]
                 fmt x y = ("; "++) . shows x . (" -> "++) . shows y

-- Int version, not safe for large-sized types

size (x::a) = 1 + fromEnum (maxBound :: a) - fromEnum (minBound :: a)

full :: (Enum a, Bounded a) => [a]
full = [ minBound .. maxBound ]

-- positional notation utilities

sumProd b x y = b * x + y
swap (x,y) = (y,x)

baser   b = foldr         (flip   ( sumProd b)) 0
unbaser b = unfoldr (==0) (swap . (`divMod` b))

unfoldr p f x = if p x then [] else a : (unfoldr p f y)
                where (a,y) = f x


-------------
-- Sample test cases:


-- basic Boolean operator example
test0 = (&&) == (||)

-- simple deMorgan's law example
test1 = (&&) == (\x y -> not (not x || not y))

-- a higher-order example using deMorgan's law
test2 = (\q a -> not a || not (q a)) == flip (\b p -> not (p b && b))

-- equality between functions yielding lists of boolean functions (!)
test3 = (\x -> [(&&x), (||x), not]) == (\y -> [(y&&), (y||), not . not . not])

----------- end of file -----------
40:26: Warning: Redundant $
Found:
map (fromEnum . f) $ full
Why not:
map (fromEnum . f) full
70:37: Warning: Redundant bracket
Found:
a : (unfoldr p f y)
Why not:
a : unfoldr p f y